1 /* Intrinsic translation
2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
30 #include "diagnostic-core.h" /* For internal_error. */
31 #include "toplev.h" /* For rest_of_decl_compilation. */
35 #include "intrinsic.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
43 /* This maps Fortran intrinsic math functions to external library or GCC
45 typedef struct GTY(()) gfc_intrinsic_map_t
{
46 /* The explicit enum is required to work around inadequacies in the
47 garbage collection/gengtype parsing mechanism. */
50 /* Enum value from the "language-independent", aka C-centric, part
51 of gcc, or END_BUILTINS of no such value set. */
52 enum built_in_function float_built_in
;
53 enum built_in_function double_built_in
;
54 enum built_in_function long_double_built_in
;
55 enum built_in_function complex_float_built_in
;
56 enum built_in_function complex_double_built_in
;
57 enum built_in_function complex_long_double_built_in
;
59 /* True if the naming pattern is to prepend "c" for complex and
60 append "f" for kind=4. False if the naming pattern is to
61 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
64 /* True if a complex version of the function exists. */
65 bool complex_available
;
67 /* True if the function should be marked const. */
70 /* The base library name of this function. */
73 /* Cache decls created for the various operand types. */
85 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
86 defines complex variants of all of the entries in mathbuiltins.def
88 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
89 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
90 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
91 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
92 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
94 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
97 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
102 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
106 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
107 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
108 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
112 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
114 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
115 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
116 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
117 #include "mathbuiltins.def"
119 /* Functions in libgfortran. */
120 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
123 LIB_FUNCTION (NONE
, NULL
, false)
128 #undef DEFINE_MATH_BUILTIN
129 #undef DEFINE_MATH_BUILTIN_C
132 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
135 /* Find the correct variant of a given builtin from its argument. */
137 builtin_decl_for_precision (enum built_in_function base_built_in
,
140 enum built_in_function i
= END_BUILTINS
;
142 gfc_intrinsic_map_t
*m
;
143 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
146 if (precision
== TYPE_PRECISION (float_type_node
))
147 i
= m
->float_built_in
;
148 else if (precision
== TYPE_PRECISION (double_type_node
))
149 i
= m
->double_built_in
;
150 else if (precision
== TYPE_PRECISION (long_double_type_node
))
151 i
= m
->long_double_built_in
;
152 else if (precision
== TYPE_PRECISION (float128_type_node
))
154 /* Special treatment, because it is not exactly a built-in, but
155 a library function. */
156 return m
->real16_decl
;
159 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
164 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
167 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
169 if (gfc_real_kinds
[i
].c_float128
)
171 /* For __float128, the story is a bit different, because we return
172 a decl to a library function rather than a built-in. */
173 gfc_intrinsic_map_t
*m
;
174 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
177 return m
->real16_decl
;
180 return builtin_decl_for_precision (double_built_in
,
181 gfc_real_kinds
[i
].mode_precision
);
185 /* Evaluate the arguments to an intrinsic function. The value
186 of NARGS may be less than the actual number of arguments in EXPR
187 to allow optional "KIND" arguments that are not included in the
188 generated code to be ignored. */
191 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
192 tree
*argarray
, int nargs
)
194 gfc_actual_arglist
*actual
;
196 gfc_intrinsic_arg
*formal
;
200 formal
= expr
->value
.function
.isym
->formal
;
201 actual
= expr
->value
.function
.actual
;
203 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
204 actual
= actual
->next
,
205 formal
= formal
? formal
->next
: NULL
)
209 /* Skip omitted optional arguments. */
216 /* Evaluate the parameter. This will substitute scalarized
217 references automatically. */
218 gfc_init_se (&argse
, se
);
220 if (e
->ts
.type
== BT_CHARACTER
)
222 gfc_conv_expr (&argse
, e
);
223 gfc_conv_string_parameter (&argse
);
224 argarray
[curr_arg
++] = argse
.string_length
;
225 gcc_assert (curr_arg
< nargs
);
228 gfc_conv_expr_val (&argse
, e
);
230 /* If an optional argument is itself an optional dummy argument,
231 check its presence and substitute a null if absent. */
232 if (e
->expr_type
== EXPR_VARIABLE
233 && e
->symtree
->n
.sym
->attr
.optional
236 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
238 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
239 gfc_add_block_to_block (&se
->post
, &argse
.post
);
240 argarray
[curr_arg
] = argse
.expr
;
244 /* Count the number of actual arguments to the intrinsic function EXPR
245 including any "hidden" string length arguments. */
248 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
251 gfc_actual_arglist
*actual
;
253 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
258 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
268 /* Conversions between different types are output by the frontend as
269 intrinsic functions. We implement these directly with inline code. */
272 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
278 nargs
= gfc_intrinsic_argument_list_length (expr
);
279 args
= XALLOCAVEC (tree
, nargs
);
281 /* Evaluate all the arguments passed. Whilst we're only interested in the
282 first one here, there are other parts of the front-end that assume this
283 and will trigger an ICE if it's not the case. */
284 type
= gfc_typenode_for_spec (&expr
->ts
);
285 gcc_assert (expr
->value
.function
.actual
->expr
);
286 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
288 /* Conversion between character kinds involves a call to a library
290 if (expr
->ts
.type
== BT_CHARACTER
)
292 tree fndecl
, var
, addr
, tmp
;
294 if (expr
->ts
.kind
== 1
295 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
296 fndecl
= gfor_fndecl_convert_char4_to_char1
;
297 else if (expr
->ts
.kind
== 4
298 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
299 fndecl
= gfor_fndecl_convert_char1_to_char4
;
303 /* Create the variable storing the converted value. */
304 type
= gfc_get_pchar_type (expr
->ts
.kind
);
305 var
= gfc_create_var (type
, "str");
306 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
308 /* Call the library function that will perform the conversion. */
309 gcc_assert (nargs
>= 2);
310 tmp
= build_call_expr_loc (input_location
,
311 fndecl
, 3, addr
, args
[0], args
[1]);
312 gfc_add_expr_to_block (&se
->pre
, tmp
);
314 /* Free the temporary afterwards. */
315 tmp
= gfc_call_free (var
);
316 gfc_add_expr_to_block (&se
->post
, tmp
);
319 se
->string_length
= args
[0];
324 /* Conversion from complex to non-complex involves taking the real
325 component of the value. */
326 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
327 && expr
->ts
.type
!= BT_COMPLEX
)
331 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
332 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
336 se
->expr
= convert (type
, args
[0]);
339 /* This is needed because the gcc backend only implements
340 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
341 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
342 Similarly for CEILING. */
345 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
352 argtype
= TREE_TYPE (arg
);
353 arg
= gfc_evaluate_now (arg
, pblock
);
355 intval
= convert (type
, arg
);
356 intval
= gfc_evaluate_now (intval
, pblock
);
358 tmp
= convert (argtype
, intval
);
359 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
360 boolean_type_node
, tmp
, arg
);
362 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
363 intval
, build_int_cst (type
, 1));
364 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
369 /* Round to nearest integer, away from zero. */
372 build_round_expr (tree arg
, tree restype
)
376 int argprec
, resprec
;
378 argtype
= TREE_TYPE (arg
);
379 argprec
= TYPE_PRECISION (argtype
);
380 resprec
= TYPE_PRECISION (restype
);
382 /* Depending on the type of the result, choose the int intrinsic
383 (iround, available only as a builtin, therefore cannot use it for
384 __float128), long int intrinsic (lround family) or long long
385 intrinsic (llround). We might also need to convert the result
387 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
388 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
389 else if (resprec
<= LONG_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
391 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
396 return fold_convert (restype
, build_call_expr_loc (input_location
,
401 /* Convert a real to an integer using a specific rounding mode.
402 Ideally we would just build the corresponding GENERIC node,
403 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
406 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
407 enum rounding_mode op
)
412 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
420 return build_round_expr (arg
, type
);
424 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
433 /* Round a real value using the specified rounding mode.
434 We use a temporary integer of that same kind size as the result.
435 Values larger than those that can be represented by this kind are
436 unchanged, as they will not be accurate enough to represent the
438 huge = HUGE (KIND (a))
439 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
443 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
455 kind
= expr
->ts
.kind
;
456 nargs
= gfc_intrinsic_argument_list_length (expr
);
459 /* We have builtin functions for some cases. */
463 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
467 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
474 /* Evaluate the argument. */
475 gcc_assert (expr
->value
.function
.actual
->expr
);
476 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
478 /* Use a builtin function if one exists. */
479 if (decl
!= NULL_TREE
)
481 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
485 /* This code is probably redundant, but we'll keep it lying around just
487 type
= gfc_typenode_for_spec (&expr
->ts
);
488 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
490 /* Test if the value is too large to handle sensibly. */
491 gfc_set_model_kind (kind
);
493 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
494 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
495 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
496 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
499 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
503 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
505 itype
= gfc_get_int_type (kind
);
507 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
508 tmp
= convert (type
, tmp
);
509 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
515 /* Convert to an integer using the specified rounding mode. */
518 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
524 nargs
= gfc_intrinsic_argument_list_length (expr
);
525 args
= XALLOCAVEC (tree
, nargs
);
527 /* Evaluate the argument, we process all arguments even though we only
528 use the first one for code generation purposes. */
529 type
= gfc_typenode_for_spec (&expr
->ts
);
530 gcc_assert (expr
->value
.function
.actual
->expr
);
531 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
533 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
535 /* Conversion to a different integer kind. */
536 se
->expr
= convert (type
, args
[0]);
540 /* Conversion from complex to non-complex involves taking the real
541 component of the value. */
542 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
543 && expr
->ts
.type
!= BT_COMPLEX
)
547 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
548 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
552 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
557 /* Get the imaginary component of a value. */
560 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
564 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
565 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
566 TREE_TYPE (TREE_TYPE (arg
)), arg
);
570 /* Get the complex conjugate of a value. */
573 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
577 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
578 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
584 define_quad_builtin (const char *name
, tree type
, bool is_const
)
587 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
590 /* Mark the decl as external. */
591 DECL_EXTERNAL (fndecl
) = 1;
592 TREE_PUBLIC (fndecl
) = 1;
594 /* Mark it __attribute__((const)). */
595 TREE_READONLY (fndecl
) = is_const
;
597 rest_of_decl_compilation (fndecl
, 1, 0);
604 /* Initialize function decls for library functions. The external functions
605 are created as required. Builtin functions are added here. */
608 gfc_build_intrinsic_lib_fndecls (void)
610 gfc_intrinsic_map_t
*m
;
611 tree quad_decls
[END_BUILTINS
+ 1];
613 if (gfc_real16_is_float128
)
615 /* If we have soft-float types, we create the decls for their
616 C99-like library functions. For now, we only handle __float128
617 q-suffixed functions. */
619 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
620 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
622 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
624 type
= float128_type_node
;
625 complex_type
= complex_float128_type_node
;
626 /* type (*) (type) */
627 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
629 func_iround
= build_function_type_list (integer_type_node
,
631 /* long (*) (type) */
632 func_lround
= build_function_type_list (long_integer_type_node
,
634 /* long long (*) (type) */
635 func_llround
= build_function_type_list (long_long_integer_type_node
,
637 /* type (*) (type, type) */
638 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
639 /* type (*) (type, &int) */
641 = build_function_type_list (type
,
643 build_pointer_type (integer_type_node
),
645 /* type (*) (type, int) */
646 func_scalbn
= build_function_type_list (type
,
647 type
, integer_type_node
, NULL_TREE
);
648 /* type (*) (complex type) */
649 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
650 /* complex type (*) (complex type, complex type) */
652 = build_function_type_list (complex_type
,
653 complex_type
, complex_type
, NULL_TREE
);
655 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
656 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
657 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
659 /* Only these built-ins are actually needed here. These are used directly
660 from the code, when calling builtin_decl_for_precision() or
661 builtin_decl_for_float_type(). The others are all constructed by
662 gfc_get_intrinsic_lib_fndecl(). */
663 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
664 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
666 #include "mathbuiltins.def"
670 #undef DEFINE_MATH_BUILTIN
671 #undef DEFINE_MATH_BUILTIN_C
675 /* Add GCC builtin functions. */
676 for (m
= gfc_intrinsic_map
;
677 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
679 if (m
->float_built_in
!= END_BUILTINS
)
680 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
681 if (m
->complex_float_built_in
!= END_BUILTINS
)
682 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
683 if (m
->double_built_in
!= END_BUILTINS
)
684 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
685 if (m
->complex_double_built_in
!= END_BUILTINS
)
686 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
688 /* If real(kind=10) exists, it is always long double. */
689 if (m
->long_double_built_in
!= END_BUILTINS
)
690 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
691 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
693 = builtin_decl_explicit (m
->complex_long_double_built_in
);
695 if (!gfc_real16_is_float128
)
697 if (m
->long_double_built_in
!= END_BUILTINS
)
698 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
699 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
701 = builtin_decl_explicit (m
->complex_long_double_built_in
);
703 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
705 /* Quad-precision function calls are constructed when first
706 needed by builtin_decl_for_precision(), except for those
707 that will be used directly (define by OTHER_BUILTIN). */
708 m
->real16_decl
= quad_decls
[m
->double_built_in
];
710 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
712 /* Same thing for the complex ones. */
713 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
719 /* Create a fndecl for a simple intrinsic library function. */
722 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
725 vec
<tree
, va_gc
> *argtypes
;
727 gfc_actual_arglist
*actual
;
730 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
733 if (ts
->type
== BT_REAL
)
738 pdecl
= &m
->real4_decl
;
741 pdecl
= &m
->real8_decl
;
744 pdecl
= &m
->real10_decl
;
747 pdecl
= &m
->real16_decl
;
753 else if (ts
->type
== BT_COMPLEX
)
755 gcc_assert (m
->complex_available
);
760 pdecl
= &m
->complex4_decl
;
763 pdecl
= &m
->complex8_decl
;
766 pdecl
= &m
->complex10_decl
;
769 pdecl
= &m
->complex16_decl
;
783 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
784 if (gfc_real_kinds
[n
].c_float
)
785 snprintf (name
, sizeof (name
), "%s%s%s",
786 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
787 else if (gfc_real_kinds
[n
].c_double
)
788 snprintf (name
, sizeof (name
), "%s%s",
789 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
790 else if (gfc_real_kinds
[n
].c_long_double
)
791 snprintf (name
, sizeof (name
), "%s%s%s",
792 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
793 else if (gfc_real_kinds
[n
].c_float128
)
794 snprintf (name
, sizeof (name
), "%s%s%s",
795 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
801 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
802 ts
->type
== BT_COMPLEX
? 'c' : 'r',
807 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
809 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
810 vec_safe_push (argtypes
, type
);
812 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
813 fndecl
= build_decl (input_location
,
814 FUNCTION_DECL
, get_identifier (name
), type
);
816 /* Mark the decl as external. */
817 DECL_EXTERNAL (fndecl
) = 1;
818 TREE_PUBLIC (fndecl
) = 1;
820 /* Mark it __attribute__((const)), if possible. */
821 TREE_READONLY (fndecl
) = m
->is_constant
;
823 rest_of_decl_compilation (fndecl
, 1, 0);
830 /* Convert an intrinsic function into an external or builtin call. */
833 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
835 gfc_intrinsic_map_t
*m
;
839 unsigned int num_args
;
842 id
= expr
->value
.function
.isym
->id
;
843 /* Find the entry for this function. */
844 for (m
= gfc_intrinsic_map
;
845 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
851 if (m
->id
== GFC_ISYM_NONE
)
853 internal_error ("Intrinsic function %s(%d) not recognized",
854 expr
->value
.function
.name
, id
);
857 /* Get the decl and generate the call. */
858 num_args
= gfc_intrinsic_argument_list_length (expr
);
859 args
= XALLOCAVEC (tree
, num_args
);
861 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
862 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
863 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
865 fndecl
= build_addr (fndecl
, current_function_decl
);
866 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
870 /* If bounds-checking is enabled, create code to verify at runtime that the
871 string lengths for both expressions are the same (needed for e.g. MERGE).
872 If bounds-checking is not enabled, does nothing. */
875 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
876 tree a
, tree b
, stmtblock_t
* target
)
881 /* If bounds-checking is disabled, do nothing. */
882 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
885 /* Compare the two string lengths. */
886 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
888 /* Output the runtime-check. */
889 name
= gfc_build_cstring_const (intr_name
);
890 name
= gfc_build_addr_expr (pchar_type_node
, name
);
891 gfc_trans_runtime_check (true, false, cond
, target
, where
,
892 "Unequal character lengths (%ld/%ld) in %s",
893 fold_convert (long_integer_type_node
, a
),
894 fold_convert (long_integer_type_node
, b
), name
);
898 /* The EXPONENT(s) intrinsic function is translated into
905 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
907 tree arg
, type
, res
, tmp
, frexp
;
909 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
910 expr
->value
.function
.actual
->expr
->ts
.kind
);
912 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
914 res
= gfc_create_var (integer_type_node
, NULL
);
915 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
916 gfc_build_addr_expr (NULL_TREE
, res
));
917 gfc_add_expr_to_block (&se
->pre
, tmp
);
919 type
= gfc_typenode_for_spec (&expr
->ts
);
920 se
->expr
= fold_convert (type
, res
);
925 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
928 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
929 lbound
, ubound
, extent
, ml
;
933 /* The case -fcoarray=single is handled elsewhere. */
934 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
936 gfc_init_coarray_decl (false);
938 /* Argument-free version: THIS_IMAGE(). */
939 if (expr
->value
.function
.actual
->expr
== NULL
)
941 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
942 gfort_gvar_caf_this_image
);
946 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
948 type
= gfc_get_int_type (gfc_default_integer_kind
);
949 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
950 rank
= expr
->value
.function
.actual
->expr
->rank
;
952 /* Obtain the descriptor of the COARRAY. */
953 gfc_init_se (&argse
, NULL
);
954 argse
.want_coarray
= 1;
955 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
956 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
957 gfc_add_block_to_block (&se
->post
, &argse
.post
);
962 /* Create an implicit second parameter from the loop variable. */
963 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
964 gcc_assert (corank
> 0);
965 gcc_assert (se
->loop
->dimen
== 1);
966 gcc_assert (se
->ss
->info
->expr
== expr
);
968 dim_arg
= se
->loop
->loopvar
[0];
969 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
970 gfc_array_index_type
, dim_arg
,
971 build_int_cst (TREE_TYPE (dim_arg
), 1));
972 gfc_advance_se_ss_chain (se
);
976 /* Use the passed DIM= argument. */
977 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
978 gfc_init_se (&argse
, NULL
);
979 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
980 gfc_array_index_type
);
981 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
982 dim_arg
= argse
.expr
;
984 if (INTEGER_CST_P (dim_arg
))
988 hi
= TREE_INT_CST_HIGH (dim_arg
);
989 co_dim
= TREE_INT_CST_LOW (dim_arg
);
991 || co_dim
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
992 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
993 "dimension index", expr
->value
.function
.isym
->name
,
996 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
998 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
999 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1001 build_int_cst (TREE_TYPE (dim_arg
), 1));
1002 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1003 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1005 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1006 boolean_type_node
, cond
, tmp
);
1007 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1012 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1013 one always has a dim_arg argument.
1015 m = this_image() - 1
1018 sub(1) = m + lcobound(corank)
1022 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1025 extent = gfc_extent(i)
1033 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1034 : m + lcobound(corank)
1037 /* this_image () - 1. */
1038 tmp
= fold_convert (type
, gfort_gvar_caf_this_image
);
1039 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, tmp
,
1040 build_int_cst (type
, 1));
1043 /* sub(1) = m + lcobound(corank). */
1044 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1045 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1047 lbound
= fold_convert (type
, lbound
);
1048 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1054 m
= gfc_create_var (type
, NULL
);
1055 ml
= gfc_create_var (type
, NULL
);
1056 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1057 min_var
= gfc_create_var (integer_type_node
, NULL
);
1059 /* m = this_image () - 1. */
1060 gfc_add_modify (&se
->pre
, m
, tmp
);
1062 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1063 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1064 fold_convert (integer_type_node
, dim_arg
),
1065 build_int_cst (integer_type_node
, rank
- 1));
1066 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1067 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1069 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1072 tmp
= build_int_cst (integer_type_node
, rank
);
1073 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1075 exit_label
= gfc_build_label_decl (NULL_TREE
);
1076 TREE_USED (exit_label
) = 1;
1079 gfc_init_block (&loop
);
1082 gfc_add_modify (&loop
, ml
, m
);
1085 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1086 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1087 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1088 extent
= fold_convert (type
, extent
);
1091 gfc_add_modify (&loop
, m
,
1092 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1095 /* Exit condition: if (i >= min_var) goto exit_label. */
1096 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1098 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1099 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1100 build_empty_stmt (input_location
));
1101 gfc_add_expr_to_block (&loop
, tmp
);
1103 /* Increment loop variable: i++. */
1104 gfc_add_modify (&loop
, loop_var
,
1105 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1107 build_int_cst (integer_type_node
, 1)));
1109 /* Making the loop... actually loop! */
1110 tmp
= gfc_finish_block (&loop
);
1111 tmp
= build1_v (LOOP_EXPR
, tmp
);
1112 gfc_add_expr_to_block (&se
->pre
, tmp
);
1114 /* The exit label. */
1115 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1116 gfc_add_expr_to_block (&se
->pre
, tmp
);
1118 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1119 : m + lcobound(corank) */
1121 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1122 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1124 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1125 fold_build2_loc (input_location
, PLUS_EXPR
,
1126 gfc_array_index_type
, dim_arg
,
1127 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1128 lbound
= fold_convert (type
, lbound
);
1130 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1131 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1133 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1135 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1136 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1142 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1144 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1146 gfc_se argse
, subse
;
1147 int rank
, corank
, codim
;
1149 type
= gfc_get_int_type (gfc_default_integer_kind
);
1150 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1151 rank
= expr
->value
.function
.actual
->expr
->rank
;
1153 /* Obtain the descriptor of the COARRAY. */
1154 gfc_init_se (&argse
, NULL
);
1155 argse
.want_coarray
= 1;
1156 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1157 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1158 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1161 /* Obtain a handle to the SUB argument. */
1162 gfc_init_se (&subse
, NULL
);
1163 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1164 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1165 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1166 subdesc
= build_fold_indirect_ref_loc (input_location
,
1167 gfc_conv_descriptor_data_get (subse
.expr
));
1169 /* Fortran 2008 does not require that the values remain in the cobounds,
1170 thus we need explicitly check this - and return 0 if they are exceeded. */
1172 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1173 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1174 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1175 fold_convert (gfc_array_index_type
, tmp
),
1178 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1180 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1181 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1182 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1183 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1184 fold_convert (gfc_array_index_type
, tmp
),
1186 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1187 boolean_type_node
, invalid_bound
, cond
);
1188 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1189 fold_convert (gfc_array_index_type
, tmp
),
1191 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1192 boolean_type_node
, invalid_bound
, cond
);
1195 invalid_bound
= gfc_unlikely (invalid_bound
);
1198 /* See Fortran 2008, C.10 for the following algorithm. */
1200 /* coindex = sub(corank) - lcobound(n). */
1201 coindex
= fold_convert (gfc_array_index_type
,
1202 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1204 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1205 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1206 fold_convert (gfc_array_index_type
, coindex
),
1209 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1211 tree extent
, ubound
;
1213 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1214 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1215 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1216 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1218 /* coindex *= extent. */
1219 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1220 gfc_array_index_type
, coindex
, extent
);
1222 /* coindex += sub(codim). */
1223 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1224 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1225 gfc_array_index_type
, coindex
,
1226 fold_convert (gfc_array_index_type
, tmp
));
1228 /* coindex -= lbound(codim). */
1229 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1230 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1231 gfc_array_index_type
, coindex
, lbound
);
1234 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1235 fold_convert(type
, coindex
),
1236 build_int_cst (type
, 1));
1238 /* Return 0 if "coindex" exceeds num_images(). */
1240 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1241 num_images
= build_int_cst (type
, 1);
1244 gfc_init_coarray_decl (false);
1245 num_images
= fold_convert (type
, gfort_gvar_caf_num_images
);
1248 tmp
= gfc_create_var (type
, NULL
);
1249 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1251 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1253 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1255 fold_convert (boolean_type_node
, invalid_bound
));
1256 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1257 build_int_cst (type
, 0), tmp
);
1262 trans_num_images (gfc_se
* se
)
1264 gfc_init_coarray_decl (false);
1265 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1266 gfort_gvar_caf_num_images
);
1271 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1275 gfc_init_se (&argse
, NULL
);
1276 argse
.data_not_needed
= 1;
1277 argse
.descriptor_only
= 1;
1279 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1280 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1281 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1283 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1287 /* Evaluate a single upper or lower bound. */
1288 /* TODO: bound intrinsic generates way too much unnecessary code. */
1291 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1293 gfc_actual_arglist
*arg
;
1294 gfc_actual_arglist
*arg2
;
1299 tree cond
, cond1
, cond3
, cond4
, size
;
1303 gfc_array_spec
* as
;
1304 bool assumed_rank_lb_one
;
1306 arg
= expr
->value
.function
.actual
;
1311 /* Create an implicit second parameter from the loop variable. */
1312 gcc_assert (!arg2
->expr
);
1313 gcc_assert (se
->loop
->dimen
== 1);
1314 gcc_assert (se
->ss
->info
->expr
== expr
);
1315 gfc_advance_se_ss_chain (se
);
1316 bound
= se
->loop
->loopvar
[0];
1317 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1318 gfc_array_index_type
, bound
,
1323 /* use the passed argument. */
1324 gcc_assert (arg2
->expr
);
1325 gfc_init_se (&argse
, NULL
);
1326 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1327 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1329 /* Convert from one based to zero based. */
1330 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1331 gfc_array_index_type
, bound
,
1332 gfc_index_one_node
);
1335 /* TODO: don't re-evaluate the descriptor on each iteration. */
1336 /* Get a descriptor for the first parameter. */
1337 gfc_init_se (&argse
, NULL
);
1338 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1339 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1340 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1344 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1346 if (INTEGER_CST_P (bound
))
1350 hi
= TREE_INT_CST_HIGH (bound
);
1351 low
= TREE_INT_CST_LOW (bound
);
1353 || ((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1354 && low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1355 || low
> GFC_MAX_DIMENSIONS
)
1356 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1357 "dimension index", upper
? "UBOUND" : "LBOUND",
1361 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1363 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1365 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1366 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1367 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1368 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1369 tmp
= gfc_conv_descriptor_rank (desc
);
1371 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1372 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1373 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1374 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1375 boolean_type_node
, cond
, tmp
);
1376 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1381 /* Take care of the lbound shift for assumed-rank arrays, which are
1382 nonallocatable and nonpointers. Those has a lbound of 1. */
1383 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1384 && ((arg
->expr
->ts
.type
!= BT_CLASS
1385 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1386 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1387 || (arg
->expr
->ts
.type
== BT_CLASS
1388 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1389 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1391 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1392 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1394 /* 13.14.53: Result value for LBOUND
1396 Case (i): For an array section or for an array expression other than a
1397 whole array or array structure component, LBOUND(ARRAY, DIM)
1398 has the value 1. For a whole array or array structure
1399 component, LBOUND(ARRAY, DIM) has the value:
1400 (a) equal to the lower bound for subscript DIM of ARRAY if
1401 dimension DIM of ARRAY does not have extent zero
1402 or if ARRAY is an assumed-size array of rank DIM,
1405 13.14.113: Result value for UBOUND
1407 Case (i): For an array section or for an array expression other than a
1408 whole array or array structure component, UBOUND(ARRAY, DIM)
1409 has the value equal to the number of elements in the given
1410 dimension; otherwise, it has a value equal to the upper bound
1411 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1412 not have size zero and has value zero if dimension DIM has
1415 if (!upper
&& assumed_rank_lb_one
)
1416 se
->expr
= gfc_index_one_node
;
1419 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1421 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1423 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1424 stride
, gfc_index_zero_node
);
1425 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1426 boolean_type_node
, cond3
, cond1
);
1427 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1428 stride
, gfc_index_zero_node
);
1433 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1434 boolean_type_node
, cond3
, cond4
);
1435 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1436 gfc_index_one_node
, lbound
);
1437 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1438 boolean_type_node
, cond4
, cond5
);
1440 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1441 boolean_type_node
, cond
, cond5
);
1443 if (assumed_rank_lb_one
)
1445 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1446 gfc_array_index_type
, ubound
, lbound
);
1447 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1448 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1453 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1454 gfc_array_index_type
, cond
,
1455 tmp
, gfc_index_zero_node
);
1459 if (as
->type
== AS_ASSUMED_SIZE
)
1460 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1461 bound
, build_int_cst (TREE_TYPE (bound
),
1462 arg
->expr
->rank
- 1));
1464 cond
= boolean_false_node
;
1466 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1467 boolean_type_node
, cond3
, cond4
);
1468 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1469 boolean_type_node
, cond
, cond1
);
1471 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1472 gfc_array_index_type
, cond
,
1473 lbound
, gfc_index_one_node
);
1480 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1481 gfc_array_index_type
, ubound
, lbound
);
1482 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1483 gfc_array_index_type
, size
,
1484 gfc_index_one_node
);
1485 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1486 gfc_array_index_type
, se
->expr
,
1487 gfc_index_zero_node
);
1490 se
->expr
= gfc_index_one_node
;
1493 type
= gfc_typenode_for_spec (&expr
->ts
);
1494 se
->expr
= convert (type
, se
->expr
);
1499 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1501 gfc_actual_arglist
*arg
;
1502 gfc_actual_arglist
*arg2
;
1504 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1508 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1509 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1510 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1512 arg
= expr
->value
.function
.actual
;
1515 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1516 corank
= gfc_get_corank (arg
->expr
);
1518 gfc_init_se (&argse
, NULL
);
1519 argse
.want_coarray
= 1;
1521 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1522 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1523 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1528 /* Create an implicit second parameter from the loop variable. */
1529 gcc_assert (!arg2
->expr
);
1530 gcc_assert (corank
> 0);
1531 gcc_assert (se
->loop
->dimen
== 1);
1532 gcc_assert (se
->ss
->info
->expr
== expr
);
1534 bound
= se
->loop
->loopvar
[0];
1535 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1536 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1537 gfc_advance_se_ss_chain (se
);
1541 /* use the passed argument. */
1542 gcc_assert (arg2
->expr
);
1543 gfc_init_se (&argse
, NULL
);
1544 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1545 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1548 if (INTEGER_CST_P (bound
))
1552 hi
= TREE_INT_CST_HIGH (bound
);
1553 low
= TREE_INT_CST_LOW (bound
);
1554 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1555 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1556 "dimension index", expr
->value
.function
.isym
->name
,
1559 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1561 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1562 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1563 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1564 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1565 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1567 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1568 boolean_type_node
, cond
, tmp
);
1569 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1574 /* Subtract 1 to get to zero based and add dimensions. */
1575 switch (arg
->expr
->rank
)
1578 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1579 gfc_array_index_type
, bound
,
1580 gfc_index_one_node
);
1584 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1585 gfc_array_index_type
, bound
,
1586 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1590 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1592 /* Handle UCOBOUND with special handling of the last codimension. */
1593 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1595 /* Last codimension: For -fcoarray=single just return
1596 the lcobound - otherwise add
1597 ceiling (real (num_images ()) / real (size)) - 1
1598 = (num_images () + size - 1) / size - 1
1599 = (num_images - 1) / size(),
1600 where size is the product of the extent of all but the last
1603 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1607 gfc_init_coarray_decl (false);
1608 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1610 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1611 gfc_array_index_type
,
1612 fold_convert (gfc_array_index_type
,
1613 gfort_gvar_caf_num_images
),
1614 build_int_cst (gfc_array_index_type
, 1));
1615 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1616 gfc_array_index_type
, tmp
,
1617 fold_convert (gfc_array_index_type
, cosize
));
1618 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1619 gfc_array_index_type
, resbound
, tmp
);
1621 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1623 /* ubound = lbound + num_images() - 1. */
1624 gfc_init_coarray_decl (false);
1625 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1626 gfc_array_index_type
,
1627 fold_convert (gfc_array_index_type
,
1628 gfort_gvar_caf_num_images
),
1629 build_int_cst (gfc_array_index_type
, 1));
1630 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1631 gfc_array_index_type
, resbound
, tmp
);
1636 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1638 build_int_cst (TREE_TYPE (bound
),
1639 arg
->expr
->rank
+ corank
- 1));
1641 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1642 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1643 gfc_array_index_type
, cond
,
1644 resbound
, resbound2
);
1647 se
->expr
= resbound
;
1650 se
->expr
= resbound
;
1652 type
= gfc_typenode_for_spec (&expr
->ts
);
1653 se
->expr
= convert (type
, se
->expr
);
1658 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
1660 gfc_actual_arglist
*array_arg
;
1661 gfc_actual_arglist
*dim_arg
;
1665 array_arg
= expr
->value
.function
.actual
;
1666 dim_arg
= array_arg
->next
;
1668 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
1670 gfc_init_se (&argse
, NULL
);
1671 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
1672 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1673 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1676 gcc_assert (dim_arg
->expr
);
1677 gfc_init_se (&argse
, NULL
);
1678 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
1679 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1680 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1681 argse
.expr
, gfc_index_one_node
);
1682 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
1687 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1691 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1693 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1697 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1702 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1703 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1712 /* Create a complex value from one or two real components. */
1715 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1721 unsigned int num_args
;
1723 num_args
= gfc_intrinsic_argument_list_length (expr
);
1724 args
= XALLOCAVEC (tree
, num_args
);
1726 type
= gfc_typenode_for_spec (&expr
->ts
);
1727 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1728 real
= convert (TREE_TYPE (type
), args
[0]);
1730 imag
= convert (TREE_TYPE (type
), args
[1]);
1731 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1733 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1734 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1735 imag
= convert (TREE_TYPE (type
), imag
);
1738 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1740 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1744 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1745 MODULO(A, P) = A - FLOOR (A / P) * P
1747 The obvious algorithms above are numerically instable for large
1748 arguments, hence these intrinsics are instead implemented via calls
1749 to the fmod family of functions. It is the responsibility of the
1750 user to ensure that the second argument is non-zero. */
1753 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1763 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1765 switch (expr
->ts
.type
)
1768 /* Integer case is easy, we've got a builtin op. */
1769 type
= TREE_TYPE (args
[0]);
1772 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1775 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1781 /* Check if we have a builtin fmod. */
1782 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1784 /* The builtin should always be available. */
1785 gcc_assert (fmod
!= NULL_TREE
);
1787 tmp
= build_addr (fmod
, current_function_decl
);
1788 se
->expr
= build_call_array_loc (input_location
,
1789 TREE_TYPE (TREE_TYPE (fmod
)),
1794 type
= TREE_TYPE (args
[0]);
1796 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1797 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1800 modulo = arg - floor (arg/arg2) * arg2
1802 In order to calculate the result accurately, we use the fmod
1803 function as follows.
1805 res = fmod (arg, arg2);
1808 if ((arg < 0) xor (arg2 < 0))
1812 res = copysign (0., arg2);
1814 => As two nested ternary exprs:
1816 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
1817 : copysign (0., arg2);
1821 zero
= gfc_build_const (type
, integer_zero_node
);
1822 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1823 if (!flag_signed_zeros
)
1825 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1827 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1829 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1830 boolean_type_node
, test
, test2
);
1831 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1833 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1834 boolean_type_node
, test
, test2
);
1835 test
= gfc_evaluate_now (test
, &se
->pre
);
1836 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1837 fold_build2_loc (input_location
,
1839 type
, tmp
, args
[1]),
1844 tree expr1
, copysign
, cscall
;
1845 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
1847 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1849 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1851 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1852 boolean_type_node
, test
, test2
);
1853 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
1854 fold_build2_loc (input_location
,
1856 type
, tmp
, args
[1]),
1858 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1860 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
1862 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1872 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1873 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1874 where the right shifts are logical (i.e. 0's are shifted in).
1875 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1876 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1878 DSHIFTL(I,J,BITSIZE) = J
1880 DSHIFTR(I,J,BITSIZE) = I. */
1883 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1885 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1886 tree args
[3], cond
, tmp
;
1889 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1891 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1892 type
= TREE_TYPE (args
[0]);
1893 bitsize
= TYPE_PRECISION (type
);
1894 utype
= unsigned_type_for (type
);
1895 stype
= TREE_TYPE (args
[2]);
1897 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1898 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1899 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1901 /* The generic case. */
1902 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1903 build_int_cst (stype
, bitsize
), shift
);
1904 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1905 arg1
, dshiftl
? shift
: tmp
);
1907 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1908 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1909 right
= fold_convert (type
, right
);
1911 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1913 /* Special cases. */
1914 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1915 build_int_cst (stype
, 0));
1916 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1917 dshiftl
? arg1
: arg2
, res
);
1919 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1920 build_int_cst (stype
, bitsize
));
1921 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1922 dshiftl
? arg2
: arg1
, res
);
1928 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1931 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1939 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1940 type
= TREE_TYPE (args
[0]);
1942 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1943 val
= gfc_evaluate_now (val
, &se
->pre
);
1945 zero
= gfc_build_const (type
, integer_zero_node
);
1946 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1947 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1951 /* SIGN(A, B) is absolute value of A times sign of B.
1952 The real value versions use library functions to ensure the correct
1953 handling of negative zero. Integer case implemented as:
1954 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1958 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1964 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1965 if (expr
->ts
.type
== BT_REAL
)
1969 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1970 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1972 /* We explicitly have to ignore the minus sign. We do so by using
1973 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1974 if (!gfc_option
.flag_sign_zero
1975 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1978 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1979 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1981 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1982 TREE_TYPE (args
[0]), cond
,
1983 build_call_expr_loc (input_location
, abs
, 1,
1985 build_call_expr_loc (input_location
, tmp
, 2,
1989 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1994 /* Having excluded floating point types, we know we are now dealing
1995 with signed integer types. */
1996 type
= TREE_TYPE (args
[0]);
1998 /* Args[0] is used multiple times below. */
1999 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2001 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2002 the signs of A and B are the same, and of all ones if they differ. */
2003 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2004 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2005 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2006 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2008 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2009 is all ones (i.e. -1). */
2010 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2011 fold_build2_loc (input_location
, PLUS_EXPR
,
2012 type
, args
[0], tmp
), tmp
);
2016 /* Test for the presence of an optional argument. */
2019 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2023 arg
= expr
->value
.function
.actual
->expr
;
2024 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2025 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2026 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2030 /* Calculate the double precision product of two single precision values. */
2033 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2038 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2040 /* Convert the args to double precision before multiplying. */
2041 type
= gfc_typenode_for_spec (&expr
->ts
);
2042 args
[0] = convert (type
, args
[0]);
2043 args
[1] = convert (type
, args
[1]);
2044 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2049 /* Return a length one character string containing an ascii character. */
2052 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2057 unsigned int num_args
;
2059 num_args
= gfc_intrinsic_argument_list_length (expr
);
2060 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2062 type
= gfc_get_char_type (expr
->ts
.kind
);
2063 var
= gfc_create_var (type
, "char");
2065 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2066 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2067 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2068 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2073 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2081 unsigned int num_args
;
2083 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2084 args
= XALLOCAVEC (tree
, num_args
);
2086 var
= gfc_create_var (pchar_type_node
, "pstr");
2087 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2089 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2090 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2091 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2093 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2094 tmp
= build_call_array_loc (input_location
,
2095 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2096 fndecl
, num_args
, args
);
2097 gfc_add_expr_to_block (&se
->pre
, tmp
);
2099 /* Free the temporary afterwards, if necessary. */
2100 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2101 len
, build_int_cst (TREE_TYPE (len
), 0));
2102 tmp
= gfc_call_free (var
);
2103 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2104 gfc_add_expr_to_block (&se
->post
, tmp
);
2107 se
->string_length
= len
;
2112 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2120 unsigned int num_args
;
2122 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2123 args
= XALLOCAVEC (tree
, num_args
);
2125 var
= gfc_create_var (pchar_type_node
, "pstr");
2126 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2128 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2129 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2130 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2132 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2133 tmp
= build_call_array_loc (input_location
,
2134 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2135 fndecl
, num_args
, args
);
2136 gfc_add_expr_to_block (&se
->pre
, tmp
);
2138 /* Free the temporary afterwards, if necessary. */
2139 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2140 len
, build_int_cst (TREE_TYPE (len
), 0));
2141 tmp
= gfc_call_free (var
);
2142 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2143 gfc_add_expr_to_block (&se
->post
, tmp
);
2146 se
->string_length
= len
;
2150 /* Return a character string containing the tty name. */
2153 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2161 unsigned int num_args
;
2163 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2164 args
= XALLOCAVEC (tree
, num_args
);
2166 var
= gfc_create_var (pchar_type_node
, "pstr");
2167 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2169 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2170 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2171 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2173 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2174 tmp
= build_call_array_loc (input_location
,
2175 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2176 fndecl
, num_args
, args
);
2177 gfc_add_expr_to_block (&se
->pre
, tmp
);
2179 /* Free the temporary afterwards, if necessary. */
2180 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2181 len
, build_int_cst (TREE_TYPE (len
), 0));
2182 tmp
= gfc_call_free (var
);
2183 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2184 gfc_add_expr_to_block (&se
->post
, tmp
);
2187 se
->string_length
= len
;
2191 /* Get the minimum/maximum value of all the parameters.
2192 minmax (a1, a2, a3, ...)
2195 if (a2 .op. mvar || isnan (mvar))
2197 if (a3 .op. mvar || isnan (mvar))
2204 /* TODO: Mismatching types can occur when specific names are used.
2205 These should be handled during resolution. */
2207 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2215 gfc_actual_arglist
*argexpr
;
2216 unsigned int i
, nargs
;
2218 nargs
= gfc_intrinsic_argument_list_length (expr
);
2219 args
= XALLOCAVEC (tree
, nargs
);
2221 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2222 type
= gfc_typenode_for_spec (&expr
->ts
);
2224 argexpr
= expr
->value
.function
.actual
;
2225 if (TREE_TYPE (args
[0]) != type
)
2226 args
[0] = convert (type
, args
[0]);
2227 /* Only evaluate the argument once. */
2228 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2229 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2231 mvar
= gfc_create_var (type
, "M");
2232 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2233 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2239 /* Handle absent optional arguments by ignoring the comparison. */
2240 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2241 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2242 && TREE_CODE (val
) == INDIRECT_REF
)
2243 cond
= fold_build2_loc (input_location
,
2244 NE_EXPR
, boolean_type_node
,
2245 TREE_OPERAND (val
, 0),
2246 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2251 /* Only evaluate the argument once. */
2252 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2253 val
= gfc_evaluate_now (val
, &se
->pre
);
2256 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2258 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2259 convert (type
, val
), mvar
);
2261 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2262 __builtin_isnan might be made dependent on that module being loaded,
2263 to help performance of programs that don't rely on IEEE semantics. */
2264 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2266 isnan
= build_call_expr_loc (input_location
,
2267 builtin_decl_explicit (BUILT_IN_ISNAN
),
2269 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2270 boolean_type_node
, tmp
,
2271 fold_convert (boolean_type_node
, isnan
));
2273 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2274 build_empty_stmt (input_location
));
2276 if (cond
!= NULL_TREE
)
2277 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2278 build_empty_stmt (input_location
));
2280 gfc_add_expr_to_block (&se
->pre
, tmp
);
2281 argexpr
= argexpr
->next
;
2287 /* Generate library calls for MIN and MAX intrinsics for character
2290 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2293 tree var
, len
, fndecl
, tmp
, cond
, function
;
2296 nargs
= gfc_intrinsic_argument_list_length (expr
);
2297 args
= XALLOCAVEC (tree
, nargs
+ 4);
2298 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2300 /* Create the result variables. */
2301 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2302 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2303 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2304 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2305 args
[2] = build_int_cst (integer_type_node
, op
);
2306 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2308 if (expr
->ts
.kind
== 1)
2309 function
= gfor_fndecl_string_minmax
;
2310 else if (expr
->ts
.kind
== 4)
2311 function
= gfor_fndecl_string_minmax_char4
;
2315 /* Make the function call. */
2316 fndecl
= build_addr (function
, current_function_decl
);
2317 tmp
= build_call_array_loc (input_location
,
2318 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2320 gfc_add_expr_to_block (&se
->pre
, tmp
);
2322 /* Free the temporary afterwards, if necessary. */
2323 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2324 len
, build_int_cst (TREE_TYPE (len
), 0));
2325 tmp
= gfc_call_free (var
);
2326 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2327 gfc_add_expr_to_block (&se
->post
, tmp
);
2330 se
->string_length
= len
;
2334 /* Create a symbol node for this intrinsic. The symbol from the frontend
2335 has the generic name. */
2338 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2342 /* TODO: Add symbols for intrinsic function to the global namespace. */
2343 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2344 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2347 sym
->attr
.external
= 1;
2348 sym
->attr
.function
= 1;
2349 sym
->attr
.always_explicit
= 1;
2350 sym
->attr
.proc
= PROC_INTRINSIC
;
2351 sym
->attr
.flavor
= FL_PROCEDURE
;
2355 sym
->attr
.dimension
= 1;
2356 sym
->as
= gfc_get_array_spec ();
2357 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2358 sym
->as
->rank
= expr
->rank
;
2361 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2366 /* Generate a call to an external intrinsic function. */
2368 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2371 vec
<tree
, va_gc
> *append_args
;
2373 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2376 gcc_assert (expr
->rank
> 0);
2378 gcc_assert (expr
->rank
== 0);
2380 sym
= gfc_get_symbol_for_expr (expr
);
2382 /* Calls to libgfortran_matmul need to be appended special arguments,
2383 to be able to call the BLAS ?gemm functions if required and possible. */
2385 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2386 && sym
->ts
.type
!= BT_LOGICAL
)
2388 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2390 if (gfc_option
.flag_external_blas
2391 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2392 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2396 if (sym
->ts
.type
== BT_REAL
)
2398 if (sym
->ts
.kind
== 4)
2399 gemm_fndecl
= gfor_fndecl_sgemm
;
2401 gemm_fndecl
= gfor_fndecl_dgemm
;
2405 if (sym
->ts
.kind
== 4)
2406 gemm_fndecl
= gfor_fndecl_cgemm
;
2408 gemm_fndecl
= gfor_fndecl_zgemm
;
2411 vec_alloc (append_args
, 3);
2412 append_args
->quick_push (build_int_cst (cint
, 1));
2413 append_args
->quick_push (build_int_cst (cint
,
2414 gfc_option
.blas_matmul_limit
));
2415 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
2420 vec_alloc (append_args
, 3);
2421 append_args
->quick_push (build_int_cst (cint
, 0));
2422 append_args
->quick_push (build_int_cst (cint
, 0));
2423 append_args
->quick_push (null_pointer_node
);
2427 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2429 gfc_free_symbol (sym
);
2432 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2452 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2461 gfc_actual_arglist
*actual
;
2468 gfc_conv_intrinsic_funcall (se
, expr
);
2472 actual
= expr
->value
.function
.actual
;
2473 type
= gfc_typenode_for_spec (&expr
->ts
);
2474 /* Initialize the result. */
2475 resvar
= gfc_create_var (type
, "test");
2477 tmp
= convert (type
, boolean_true_node
);
2479 tmp
= convert (type
, boolean_false_node
);
2480 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2482 /* Walk the arguments. */
2483 arrayss
= gfc_walk_expr (actual
->expr
);
2484 gcc_assert (arrayss
!= gfc_ss_terminator
);
2486 /* Initialize the scalarizer. */
2487 gfc_init_loopinfo (&loop
);
2488 exit_label
= gfc_build_label_decl (NULL_TREE
);
2489 TREE_USED (exit_label
) = 1;
2490 gfc_add_ss_to_loop (&loop
, arrayss
);
2492 /* Initialize the loop. */
2493 gfc_conv_ss_startstride (&loop
);
2494 gfc_conv_loop_setup (&loop
, &expr
->where
);
2496 gfc_mark_ss_chain_used (arrayss
, 1);
2497 /* Generate the loop body. */
2498 gfc_start_scalarized_body (&loop
, &body
);
2500 /* If the condition matches then set the return value. */
2501 gfc_start_block (&block
);
2503 tmp
= convert (type
, boolean_false_node
);
2505 tmp
= convert (type
, boolean_true_node
);
2506 gfc_add_modify (&block
, resvar
, tmp
);
2508 /* And break out of the loop. */
2509 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2510 gfc_add_expr_to_block (&block
, tmp
);
2512 found
= gfc_finish_block (&block
);
2514 /* Check this element. */
2515 gfc_init_se (&arrayse
, NULL
);
2516 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2517 arrayse
.ss
= arrayss
;
2518 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2520 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2521 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2522 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2523 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2524 gfc_add_expr_to_block (&body
, tmp
);
2525 gfc_add_block_to_block (&body
, &arrayse
.post
);
2527 gfc_trans_scalarizing_loops (&loop
, &body
);
2529 /* Add the exit label. */
2530 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2531 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2533 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2534 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2535 gfc_cleanup_loop (&loop
);
2540 /* COUNT(A) = Number of true elements in A. */
2542 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2549 gfc_actual_arglist
*actual
;
2555 gfc_conv_intrinsic_funcall (se
, expr
);
2559 actual
= expr
->value
.function
.actual
;
2561 type
= gfc_typenode_for_spec (&expr
->ts
);
2562 /* Initialize the result. */
2563 resvar
= gfc_create_var (type
, "count");
2564 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2566 /* Walk the arguments. */
2567 arrayss
= gfc_walk_expr (actual
->expr
);
2568 gcc_assert (arrayss
!= gfc_ss_terminator
);
2570 /* Initialize the scalarizer. */
2571 gfc_init_loopinfo (&loop
);
2572 gfc_add_ss_to_loop (&loop
, arrayss
);
2574 /* Initialize the loop. */
2575 gfc_conv_ss_startstride (&loop
);
2576 gfc_conv_loop_setup (&loop
, &expr
->where
);
2578 gfc_mark_ss_chain_used (arrayss
, 1);
2579 /* Generate the loop body. */
2580 gfc_start_scalarized_body (&loop
, &body
);
2582 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2583 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2584 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2586 gfc_init_se (&arrayse
, NULL
);
2587 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2588 arrayse
.ss
= arrayss
;
2589 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2590 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2591 build_empty_stmt (input_location
));
2593 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2594 gfc_add_expr_to_block (&body
, tmp
);
2595 gfc_add_block_to_block (&body
, &arrayse
.post
);
2597 gfc_trans_scalarizing_loops (&loop
, &body
);
2599 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2600 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2601 gfc_cleanup_loop (&loop
);
2607 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2608 struct and return the corresponding loopinfo. */
2610 static gfc_loopinfo
*
2611 enter_nested_loop (gfc_se
*se
)
2613 se
->ss
= se
->ss
->nested_ss
;
2614 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2616 return se
->ss
->loop
;
2620 /* Inline implementation of the sum and product intrinsics. */
2622 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2626 tree scale
= NULL_TREE
;
2631 gfc_loopinfo loop
, *ploop
;
2632 gfc_actual_arglist
*arg_array
, *arg_mask
;
2633 gfc_ss
*arrayss
= NULL
;
2634 gfc_ss
*maskss
= NULL
;
2638 gfc_expr
*arrayexpr
;
2643 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2649 type
= gfc_typenode_for_spec (&expr
->ts
);
2650 /* Initialize the result. */
2651 resvar
= gfc_create_var (type
, "val");
2656 scale
= gfc_create_var (type
, "scale");
2657 gfc_add_modify (&se
->pre
, scale
,
2658 gfc_build_const (type
, integer_one_node
));
2659 tmp
= gfc_build_const (type
, integer_zero_node
);
2661 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2662 tmp
= gfc_build_const (type
, integer_zero_node
);
2663 else if (op
== NE_EXPR
)
2665 tmp
= convert (type
, boolean_false_node
);
2666 else if (op
== BIT_AND_EXPR
)
2667 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2668 type
, integer_one_node
));
2670 tmp
= gfc_build_const (type
, integer_one_node
);
2672 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2674 arg_array
= expr
->value
.function
.actual
;
2676 arrayexpr
= arg_array
->expr
;
2678 if (op
== NE_EXPR
|| norm2
)
2679 /* PARITY and NORM2. */
2683 arg_mask
= arg_array
->next
->next
;
2684 gcc_assert (arg_mask
!= NULL
);
2685 maskexpr
= arg_mask
->expr
;
2688 if (expr
->rank
== 0)
2690 /* Walk the arguments. */
2691 arrayss
= gfc_walk_expr (arrayexpr
);
2692 gcc_assert (arrayss
!= gfc_ss_terminator
);
2694 if (maskexpr
&& maskexpr
->rank
> 0)
2696 maskss
= gfc_walk_expr (maskexpr
);
2697 gcc_assert (maskss
!= gfc_ss_terminator
);
2702 /* Initialize the scalarizer. */
2703 gfc_init_loopinfo (&loop
);
2704 gfc_add_ss_to_loop (&loop
, arrayss
);
2705 if (maskexpr
&& maskexpr
->rank
> 0)
2706 gfc_add_ss_to_loop (&loop
, maskss
);
2708 /* Initialize the loop. */
2709 gfc_conv_ss_startstride (&loop
);
2710 gfc_conv_loop_setup (&loop
, &expr
->where
);
2712 gfc_mark_ss_chain_used (arrayss
, 1);
2713 if (maskexpr
&& maskexpr
->rank
> 0)
2714 gfc_mark_ss_chain_used (maskss
, 1);
2719 /* All the work has been done in the parent loops. */
2720 ploop
= enter_nested_loop (se
);
2724 /* Generate the loop body. */
2725 gfc_start_scalarized_body (ploop
, &body
);
2727 /* If we have a mask, only add this element if the mask is set. */
2728 if (maskexpr
&& maskexpr
->rank
> 0)
2730 gfc_init_se (&maskse
, parent_se
);
2731 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2732 if (expr
->rank
== 0)
2734 gfc_conv_expr_val (&maskse
, maskexpr
);
2735 gfc_add_block_to_block (&body
, &maskse
.pre
);
2737 gfc_start_block (&block
);
2740 gfc_init_block (&block
);
2742 /* Do the actual summation/product. */
2743 gfc_init_se (&arrayse
, parent_se
);
2744 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2745 if (expr
->rank
== 0)
2746 arrayse
.ss
= arrayss
;
2747 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2748 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2752 /* if (x (i) != 0.0)
2758 result = 1.0 + result * val * val;
2764 result += val * val;
2767 tree res1
, res2
, cond
, absX
, val
;
2768 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2770 gfc_init_block (&ifblock1
);
2772 absX
= gfc_create_var (type
, "absX");
2773 gfc_add_modify (&ifblock1
, absX
,
2774 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2776 val
= gfc_create_var (type
, "val");
2777 gfc_add_expr_to_block (&ifblock1
, val
);
2779 gfc_init_block (&ifblock2
);
2780 gfc_add_modify (&ifblock2
, val
,
2781 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2783 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2784 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2785 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2786 gfc_build_const (type
, integer_one_node
));
2787 gfc_add_modify (&ifblock2
, resvar
, res1
);
2788 gfc_add_modify (&ifblock2
, scale
, absX
);
2789 res1
= gfc_finish_block (&ifblock2
);
2791 gfc_init_block (&ifblock3
);
2792 gfc_add_modify (&ifblock3
, val
,
2793 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2795 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2796 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2797 gfc_add_modify (&ifblock3
, resvar
, res2
);
2798 res2
= gfc_finish_block (&ifblock3
);
2800 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2802 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2803 gfc_add_expr_to_block (&ifblock1
, tmp
);
2804 tmp
= gfc_finish_block (&ifblock1
);
2806 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2808 gfc_build_const (type
, integer_zero_node
));
2810 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2811 gfc_add_expr_to_block (&block
, tmp
);
2815 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2816 gfc_add_modify (&block
, resvar
, tmp
);
2819 gfc_add_block_to_block (&block
, &arrayse
.post
);
2821 if (maskexpr
&& maskexpr
->rank
> 0)
2823 /* We enclose the above in if (mask) {...} . */
2825 tmp
= gfc_finish_block (&block
);
2826 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2827 build_empty_stmt (input_location
));
2830 tmp
= gfc_finish_block (&block
);
2831 gfc_add_expr_to_block (&body
, tmp
);
2833 gfc_trans_scalarizing_loops (ploop
, &body
);
2835 /* For a scalar mask, enclose the loop in an if statement. */
2836 if (maskexpr
&& maskexpr
->rank
== 0)
2838 gfc_init_block (&block
);
2839 gfc_add_block_to_block (&block
, &ploop
->pre
);
2840 gfc_add_block_to_block (&block
, &ploop
->post
);
2841 tmp
= gfc_finish_block (&block
);
2845 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2846 build_empty_stmt (input_location
));
2847 gfc_advance_se_ss_chain (se
);
2851 gcc_assert (expr
->rank
== 0);
2852 gfc_init_se (&maskse
, NULL
);
2853 gfc_conv_expr_val (&maskse
, maskexpr
);
2854 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2855 build_empty_stmt (input_location
));
2858 gfc_add_expr_to_block (&block
, tmp
);
2859 gfc_add_block_to_block (&se
->pre
, &block
);
2860 gcc_assert (se
->post
.head
== NULL
);
2864 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2865 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2868 if (expr
->rank
== 0)
2869 gfc_cleanup_loop (ploop
);
2873 /* result = scale * sqrt(result). */
2875 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2876 resvar
= build_call_expr_loc (input_location
,
2878 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2885 /* Inline implementation of the dot_product intrinsic. This function
2886 is based on gfc_conv_intrinsic_arith (the previous function). */
2888 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2896 gfc_actual_arglist
*actual
;
2897 gfc_ss
*arrayss1
, *arrayss2
;
2898 gfc_se arrayse1
, arrayse2
;
2899 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2901 type
= gfc_typenode_for_spec (&expr
->ts
);
2903 /* Initialize the result. */
2904 resvar
= gfc_create_var (type
, "val");
2905 if (expr
->ts
.type
== BT_LOGICAL
)
2906 tmp
= build_int_cst (type
, 0);
2908 tmp
= gfc_build_const (type
, integer_zero_node
);
2910 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2912 /* Walk argument #1. */
2913 actual
= expr
->value
.function
.actual
;
2914 arrayexpr1
= actual
->expr
;
2915 arrayss1
= gfc_walk_expr (arrayexpr1
);
2916 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2918 /* Walk argument #2. */
2919 actual
= actual
->next
;
2920 arrayexpr2
= actual
->expr
;
2921 arrayss2
= gfc_walk_expr (arrayexpr2
);
2922 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2924 /* Initialize the scalarizer. */
2925 gfc_init_loopinfo (&loop
);
2926 gfc_add_ss_to_loop (&loop
, arrayss1
);
2927 gfc_add_ss_to_loop (&loop
, arrayss2
);
2929 /* Initialize the loop. */
2930 gfc_conv_ss_startstride (&loop
);
2931 gfc_conv_loop_setup (&loop
, &expr
->where
);
2933 gfc_mark_ss_chain_used (arrayss1
, 1);
2934 gfc_mark_ss_chain_used (arrayss2
, 1);
2936 /* Generate the loop body. */
2937 gfc_start_scalarized_body (&loop
, &body
);
2938 gfc_init_block (&block
);
2940 /* Make the tree expression for [conjg(]array1[)]. */
2941 gfc_init_se (&arrayse1
, NULL
);
2942 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2943 arrayse1
.ss
= arrayss1
;
2944 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2945 if (expr
->ts
.type
== BT_COMPLEX
)
2946 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2948 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2950 /* Make the tree expression for array2. */
2951 gfc_init_se (&arrayse2
, NULL
);
2952 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2953 arrayse2
.ss
= arrayss2
;
2954 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2955 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2957 /* Do the actual product and sum. */
2958 if (expr
->ts
.type
== BT_LOGICAL
)
2960 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2961 arrayse1
.expr
, arrayse2
.expr
);
2962 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2966 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2968 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2970 gfc_add_modify (&block
, resvar
, tmp
);
2972 /* Finish up the loop block and the loop. */
2973 tmp
= gfc_finish_block (&block
);
2974 gfc_add_expr_to_block (&body
, tmp
);
2976 gfc_trans_scalarizing_loops (&loop
, &body
);
2977 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2978 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2979 gfc_cleanup_loop (&loop
);
2985 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2986 we need to handle. For performance reasons we sometimes create two
2987 loops instead of one, where the second one is much simpler.
2988 Examples for minloc intrinsic:
2989 1) Result is an array, a call is generated
2990 2) Array mask is used and NaNs need to be supported:
2996 if (pos == 0) pos = S + (1 - from);
2997 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3004 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3008 3) NaNs need to be supported, but it is known at compile time or cheaply
3009 at runtime whether array is nonempty or not:
3014 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3017 if (from <= to) pos = 1;
3021 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3025 4) NaNs aren't supported, array mask is used:
3026 limit = infinities_supported ? Infinity : huge (limit);
3030 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3036 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3040 5) Same without array mask:
3041 limit = infinities_supported ? Infinity : huge (limit);
3042 pos = (from <= to) ? 1 : 0;
3045 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3048 For 3) and 5), if mask is scalar, this all goes into a conditional,
3049 setting pos = 0; in the else branch. */
3052 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3056 stmtblock_t ifblock
;
3057 stmtblock_t elseblock
;
3068 gfc_actual_arglist
*actual
;
3073 gfc_expr
*arrayexpr
;
3080 gfc_conv_intrinsic_funcall (se
, expr
);
3084 /* Initialize the result. */
3085 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3086 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3087 type
= gfc_typenode_for_spec (&expr
->ts
);
3089 /* Walk the arguments. */
3090 actual
= expr
->value
.function
.actual
;
3091 arrayexpr
= actual
->expr
;
3092 arrayss
= gfc_walk_expr (arrayexpr
);
3093 gcc_assert (arrayss
!= gfc_ss_terminator
);
3095 actual
= actual
->next
->next
;
3096 gcc_assert (actual
);
3097 maskexpr
= actual
->expr
;
3099 if (maskexpr
&& maskexpr
->rank
!= 0)
3101 maskss
= gfc_walk_expr (maskexpr
);
3102 gcc_assert (maskss
!= gfc_ss_terminator
);
3107 if (gfc_array_size (arrayexpr
, &asize
))
3109 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3111 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3112 boolean_type_node
, nonempty
,
3113 gfc_index_zero_node
);
3118 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3119 switch (arrayexpr
->ts
.type
)
3122 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3126 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3127 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3128 arrayexpr
->ts
.kind
);
3135 /* We start with the most negative possible value for MAXLOC, and the most
3136 positive possible value for MINLOC. The most negative possible value is
3137 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3138 possible value is HUGE in both cases. */
3140 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3141 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3142 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3143 build_int_cst (type
, 1));
3145 gfc_add_modify (&se
->pre
, limit
, tmp
);
3147 /* Initialize the scalarizer. */
3148 gfc_init_loopinfo (&loop
);
3149 gfc_add_ss_to_loop (&loop
, arrayss
);
3151 gfc_add_ss_to_loop (&loop
, maskss
);
3153 /* Initialize the loop. */
3154 gfc_conv_ss_startstride (&loop
);
3156 /* The code generated can have more than one loop in sequence (see the
3157 comment at the function header). This doesn't work well with the
3158 scalarizer, which changes arrays' offset when the scalarization loops
3159 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3160 are currently inlined in the scalar case only (for which loop is of rank
3161 one). As there is no dependency to care about in that case, there is no
3162 temporary, so that we can use the scalarizer temporary code to handle
3163 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3164 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3166 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3167 should eventually go away. We could either create two loops properly,
3168 or find another way to save/restore the array offsets between the two
3169 loops (without conflicting with temporary management), or use a single
3170 loop minmaxloc implementation. See PR 31067. */
3171 loop
.temp_dim
= loop
.dimen
;
3172 gfc_conv_loop_setup (&loop
, &expr
->where
);
3174 gcc_assert (loop
.dimen
== 1);
3175 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3176 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3177 loop
.from
[0], loop
.to
[0]);
3181 /* Initialize the position to zero, following Fortran 2003. We are free
3182 to do this because Fortran 95 allows the result of an entirely false
3183 mask to be processor dependent. If we know at compile time the array
3184 is non-empty and no MASK is used, we can initialize to 1 to simplify
3186 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3187 gfc_add_modify (&loop
.pre
, pos
,
3188 fold_build3_loc (input_location
, COND_EXPR
,
3189 gfc_array_index_type
,
3190 nonempty
, gfc_index_one_node
,
3191 gfc_index_zero_node
));
3194 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3195 lab1
= gfc_build_label_decl (NULL_TREE
);
3196 TREE_USED (lab1
) = 1;
3197 lab2
= gfc_build_label_decl (NULL_TREE
);
3198 TREE_USED (lab2
) = 1;
3201 /* An offset must be added to the loop
3202 counter to obtain the required position. */
3203 gcc_assert (loop
.from
[0]);
3205 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3206 gfc_index_one_node
, loop
.from
[0]);
3207 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3209 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3211 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3212 /* Generate the loop body. */
3213 gfc_start_scalarized_body (&loop
, &body
);
3215 /* If we have a mask, only check this element if the mask is set. */
3218 gfc_init_se (&maskse
, NULL
);
3219 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3221 gfc_conv_expr_val (&maskse
, maskexpr
);
3222 gfc_add_block_to_block (&body
, &maskse
.pre
);
3224 gfc_start_block (&block
);
3227 gfc_init_block (&block
);
3229 /* Compare with the current limit. */
3230 gfc_init_se (&arrayse
, NULL
);
3231 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3232 arrayse
.ss
= arrayss
;
3233 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3234 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3236 /* We do the following if this is a more extreme value. */
3237 gfc_start_block (&ifblock
);
3239 /* Assign the value to the limit... */
3240 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3242 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3244 stmtblock_t ifblock2
;
3247 gfc_start_block (&ifblock2
);
3248 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3249 loop
.loopvar
[0], offset
);
3250 gfc_add_modify (&ifblock2
, pos
, tmp
);
3251 ifbody2
= gfc_finish_block (&ifblock2
);
3252 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3253 gfc_index_zero_node
);
3254 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3255 build_empty_stmt (input_location
));
3256 gfc_add_expr_to_block (&block
, tmp
);
3259 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3260 loop
.loopvar
[0], offset
);
3261 gfc_add_modify (&ifblock
, pos
, tmp
);
3264 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3266 ifbody
= gfc_finish_block (&ifblock
);
3268 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3271 cond
= fold_build2_loc (input_location
,
3272 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3273 boolean_type_node
, arrayse
.expr
, limit
);
3275 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3276 arrayse
.expr
, limit
);
3278 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3279 build_empty_stmt (input_location
));
3281 gfc_add_expr_to_block (&block
, ifbody
);
3285 /* We enclose the above in if (mask) {...}. */
3286 tmp
= gfc_finish_block (&block
);
3288 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3289 build_empty_stmt (input_location
));
3292 tmp
= gfc_finish_block (&block
);
3293 gfc_add_expr_to_block (&body
, tmp
);
3297 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3299 if (HONOR_NANS (DECL_MODE (limit
)))
3301 if (nonempty
!= NULL
)
3303 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3304 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3305 build_empty_stmt (input_location
));
3306 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3310 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3311 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3313 /* If we have a mask, only check this element if the mask is set. */
3316 gfc_init_se (&maskse
, NULL
);
3317 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3319 gfc_conv_expr_val (&maskse
, maskexpr
);
3320 gfc_add_block_to_block (&body
, &maskse
.pre
);
3322 gfc_start_block (&block
);
3325 gfc_init_block (&block
);
3327 /* Compare with the current limit. */
3328 gfc_init_se (&arrayse
, NULL
);
3329 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3330 arrayse
.ss
= arrayss
;
3331 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3332 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3334 /* We do the following if this is a more extreme value. */
3335 gfc_start_block (&ifblock
);
3337 /* Assign the value to the limit... */
3338 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3340 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3341 loop
.loopvar
[0], offset
);
3342 gfc_add_modify (&ifblock
, pos
, tmp
);
3344 ifbody
= gfc_finish_block (&ifblock
);
3346 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3347 arrayse
.expr
, limit
);
3349 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3350 build_empty_stmt (input_location
));
3351 gfc_add_expr_to_block (&block
, tmp
);
3355 /* We enclose the above in if (mask) {...}. */
3356 tmp
= gfc_finish_block (&block
);
3358 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3359 build_empty_stmt (input_location
));
3362 tmp
= gfc_finish_block (&block
);
3363 gfc_add_expr_to_block (&body
, tmp
);
3364 /* Avoid initializing loopvar[0] again, it should be left where
3365 it finished by the first loop. */
3366 loop
.from
[0] = loop
.loopvar
[0];
3369 gfc_trans_scalarizing_loops (&loop
, &body
);
3372 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3374 /* For a scalar mask, enclose the loop in an if statement. */
3375 if (maskexpr
&& maskss
== NULL
)
3377 gfc_init_se (&maskse
, NULL
);
3378 gfc_conv_expr_val (&maskse
, maskexpr
);
3379 gfc_init_block (&block
);
3380 gfc_add_block_to_block (&block
, &loop
.pre
);
3381 gfc_add_block_to_block (&block
, &loop
.post
);
3382 tmp
= gfc_finish_block (&block
);
3384 /* For the else part of the scalar mask, just initialize
3385 the pos variable the same way as above. */
3387 gfc_init_block (&elseblock
);
3388 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3389 elsetmp
= gfc_finish_block (&elseblock
);
3391 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3392 gfc_add_expr_to_block (&block
, tmp
);
3393 gfc_add_block_to_block (&se
->pre
, &block
);
3397 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3398 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3400 gfc_cleanup_loop (&loop
);
3402 se
->expr
= convert (type
, pos
);
3405 /* Emit code for minval or maxval intrinsic. There are many different cases
3406 we need to handle. For performance reasons we sometimes create two
3407 loops instead of one, where the second one is much simpler.
3408 Examples for minval intrinsic:
3409 1) Result is an array, a call is generated
3410 2) Array mask is used and NaNs need to be supported, rank 1:
3415 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3418 limit = nonempty ? NaN : huge (limit);
3420 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3421 3) NaNs need to be supported, but it is known at compile time or cheaply
3422 at runtime whether array is nonempty or not, rank 1:
3425 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3426 limit = (from <= to) ? NaN : huge (limit);
3428 while (S <= to) { limit = min (a[S], limit); S++; }
3429 4) Array mask is used and NaNs need to be supported, rank > 1:
3438 if (fast) limit = min (a[S1][S2], limit);
3441 if (a[S1][S2] <= limit) {
3452 limit = nonempty ? NaN : huge (limit);
3453 5) NaNs need to be supported, but it is known at compile time or cheaply
3454 at runtime whether array is nonempty or not, rank > 1:
3461 if (fast) limit = min (a[S1][S2], limit);
3463 if (a[S1][S2] <= limit) {
3473 limit = (nonempty_array) ? NaN : huge (limit);
3474 6) NaNs aren't supported, but infinities are. Array mask is used:
3479 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3482 limit = nonempty ? limit : huge (limit);
3483 7) Same without array mask:
3486 while (S <= to) { limit = min (a[S], limit); S++; }
3487 limit = (from <= to) ? limit : huge (limit);
3488 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3489 limit = huge (limit);
3491 while (S <= to) { limit = min (a[S], limit); S++); }
3493 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3494 with array mask instead).
3495 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3496 setting limit = huge (limit); in the else branch. */
3499 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3509 tree huge_cst
= NULL
, nan_cst
= NULL
;
3511 stmtblock_t block
, block2
;
3513 gfc_actual_arglist
*actual
;
3518 gfc_expr
*arrayexpr
;
3524 gfc_conv_intrinsic_funcall (se
, expr
);
3528 type
= gfc_typenode_for_spec (&expr
->ts
);
3529 /* Initialize the result. */
3530 limit
= gfc_create_var (type
, "limit");
3531 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3532 switch (expr
->ts
.type
)
3535 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3537 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3539 REAL_VALUE_TYPE real
;
3541 tmp
= build_real (type
, real
);
3545 if (HONOR_NANS (DECL_MODE (limit
)))
3547 REAL_VALUE_TYPE real
;
3548 real_nan (&real
, "", 1, DECL_MODE (limit
));
3549 nan_cst
= build_real (type
, real
);
3554 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3561 /* We start with the most negative possible value for MAXVAL, and the most
3562 positive possible value for MINVAL. The most negative possible value is
3563 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3564 possible value is HUGE in both cases. */
3567 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3569 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3570 TREE_TYPE (huge_cst
), huge_cst
);
3573 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3574 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3575 tmp
, build_int_cst (type
, 1));
3577 gfc_add_modify (&se
->pre
, limit
, tmp
);
3579 /* Walk the arguments. */
3580 actual
= expr
->value
.function
.actual
;
3581 arrayexpr
= actual
->expr
;
3582 arrayss
= gfc_walk_expr (arrayexpr
);
3583 gcc_assert (arrayss
!= gfc_ss_terminator
);
3585 actual
= actual
->next
->next
;
3586 gcc_assert (actual
);
3587 maskexpr
= actual
->expr
;
3589 if (maskexpr
&& maskexpr
->rank
!= 0)
3591 maskss
= gfc_walk_expr (maskexpr
);
3592 gcc_assert (maskss
!= gfc_ss_terminator
);
3597 if (gfc_array_size (arrayexpr
, &asize
))
3599 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3601 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3602 boolean_type_node
, nonempty
,
3603 gfc_index_zero_node
);
3608 /* Initialize the scalarizer. */
3609 gfc_init_loopinfo (&loop
);
3610 gfc_add_ss_to_loop (&loop
, arrayss
);
3612 gfc_add_ss_to_loop (&loop
, maskss
);
3614 /* Initialize the loop. */
3615 gfc_conv_ss_startstride (&loop
);
3617 /* The code generated can have more than one loop in sequence (see the
3618 comment at the function header). This doesn't work well with the
3619 scalarizer, which changes arrays' offset when the scalarization loops
3620 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3621 are currently inlined in the scalar case only. As there is no dependency
3622 to care about in that case, there is no temporary, so that we can use the
3623 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3624 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3625 gfc_trans_scalarized_loop_boundary even later to restore offset.
3626 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3627 should eventually go away. We could either create two loops properly,
3628 or find another way to save/restore the array offsets between the two
3629 loops (without conflicting with temporary management), or use a single
3630 loop minmaxval implementation. See PR 31067. */
3631 loop
.temp_dim
= loop
.dimen
;
3632 gfc_conv_loop_setup (&loop
, &expr
->where
);
3634 if (nonempty
== NULL
&& maskss
== NULL
3635 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3636 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3637 loop
.from
[0], loop
.to
[0]);
3638 nonempty_var
= NULL
;
3639 if (nonempty
== NULL
3640 && (HONOR_INFINITIES (DECL_MODE (limit
))
3641 || HONOR_NANS (DECL_MODE (limit
))))
3643 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3644 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3645 nonempty
= nonempty_var
;
3649 if (HONOR_NANS (DECL_MODE (limit
)))
3651 if (loop
.dimen
== 1)
3653 lab
= gfc_build_label_decl (NULL_TREE
);
3654 TREE_USED (lab
) = 1;
3658 fast
= gfc_create_var (boolean_type_node
, "fast");
3659 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3663 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3665 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3666 /* Generate the loop body. */
3667 gfc_start_scalarized_body (&loop
, &body
);
3669 /* If we have a mask, only add this element if the mask is set. */
3672 gfc_init_se (&maskse
, NULL
);
3673 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3675 gfc_conv_expr_val (&maskse
, maskexpr
);
3676 gfc_add_block_to_block (&body
, &maskse
.pre
);
3678 gfc_start_block (&block
);
3681 gfc_init_block (&block
);
3683 /* Compare with the current limit. */
3684 gfc_init_se (&arrayse
, NULL
);
3685 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3686 arrayse
.ss
= arrayss
;
3687 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3688 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3690 gfc_init_block (&block2
);
3693 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3695 if (HONOR_NANS (DECL_MODE (limit
)))
3697 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3698 boolean_type_node
, arrayse
.expr
, limit
);
3700 ifbody
= build1_v (GOTO_EXPR
, lab
);
3703 stmtblock_t ifblock
;
3705 gfc_init_block (&ifblock
);
3706 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3707 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3708 ifbody
= gfc_finish_block (&ifblock
);
3710 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3711 build_empty_stmt (input_location
));
3712 gfc_add_expr_to_block (&block2
, tmp
);
3716 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3718 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3720 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3721 arrayse
.expr
, limit
);
3722 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3723 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3724 build_empty_stmt (input_location
));
3725 gfc_add_expr_to_block (&block2
, tmp
);
3729 tmp
= fold_build2_loc (input_location
,
3730 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3731 type
, arrayse
.expr
, limit
);
3732 gfc_add_modify (&block2
, limit
, tmp
);
3738 tree elsebody
= gfc_finish_block (&block2
);
3740 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3742 if (HONOR_NANS (DECL_MODE (limit
))
3743 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3745 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3746 arrayse
.expr
, limit
);
3747 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3748 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3749 build_empty_stmt (input_location
));
3753 tmp
= fold_build2_loc (input_location
,
3754 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3755 type
, arrayse
.expr
, limit
);
3756 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3758 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3759 gfc_add_expr_to_block (&block
, tmp
);
3762 gfc_add_block_to_block (&block
, &block2
);
3764 gfc_add_block_to_block (&block
, &arrayse
.post
);
3766 tmp
= gfc_finish_block (&block
);
3768 /* We enclose the above in if (mask) {...}. */
3769 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3770 build_empty_stmt (input_location
));
3771 gfc_add_expr_to_block (&body
, tmp
);
3775 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3777 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3779 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3780 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3782 /* If we have a mask, only add this element if the mask is set. */
3785 gfc_init_se (&maskse
, NULL
);
3786 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3788 gfc_conv_expr_val (&maskse
, maskexpr
);
3789 gfc_add_block_to_block (&body
, &maskse
.pre
);
3791 gfc_start_block (&block
);
3794 gfc_init_block (&block
);
3796 /* Compare with the current limit. */
3797 gfc_init_se (&arrayse
, NULL
);
3798 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3799 arrayse
.ss
= arrayss
;
3800 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3801 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3803 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3805 if (HONOR_NANS (DECL_MODE (limit
))
3806 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3808 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3809 arrayse
.expr
, limit
);
3810 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3811 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3812 build_empty_stmt (input_location
));
3813 gfc_add_expr_to_block (&block
, tmp
);
3817 tmp
= fold_build2_loc (input_location
,
3818 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3819 type
, arrayse
.expr
, limit
);
3820 gfc_add_modify (&block
, limit
, tmp
);
3823 gfc_add_block_to_block (&block
, &arrayse
.post
);
3825 tmp
= gfc_finish_block (&block
);
3827 /* We enclose the above in if (mask) {...}. */
3828 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3829 build_empty_stmt (input_location
));
3830 gfc_add_expr_to_block (&body
, tmp
);
3831 /* Avoid initializing loopvar[0] again, it should be left where
3832 it finished by the first loop. */
3833 loop
.from
[0] = loop
.loopvar
[0];
3835 gfc_trans_scalarizing_loops (&loop
, &body
);
3839 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3841 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3842 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3844 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3846 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3848 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3850 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3853 /* For a scalar mask, enclose the loop in an if statement. */
3854 if (maskexpr
&& maskss
== NULL
)
3858 gfc_init_se (&maskse
, NULL
);
3859 gfc_conv_expr_val (&maskse
, maskexpr
);
3860 gfc_init_block (&block
);
3861 gfc_add_block_to_block (&block
, &loop
.pre
);
3862 gfc_add_block_to_block (&block
, &loop
.post
);
3863 tmp
= gfc_finish_block (&block
);
3865 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3866 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3868 else_stmt
= build_empty_stmt (input_location
);
3869 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3870 gfc_add_expr_to_block (&block
, tmp
);
3871 gfc_add_block_to_block (&se
->pre
, &block
);
3875 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3876 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3879 gfc_cleanup_loop (&loop
);
3884 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3886 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3892 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3893 type
= TREE_TYPE (args
[0]);
3895 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3896 build_int_cst (type
, 1), args
[1]);
3897 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3898 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3899 build_int_cst (type
, 0));
3900 type
= gfc_typenode_for_spec (&expr
->ts
);
3901 se
->expr
= convert (type
, tmp
);
3905 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3907 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3911 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3913 /* Convert both arguments to the unsigned type of the same size. */
3914 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3915 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3917 /* If they have unequal type size, convert to the larger one. */
3918 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3919 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3920 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3921 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3922 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3923 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3925 /* Now, we compare them. */
3926 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3931 /* Generate code to perform the specified operation. */
3933 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3937 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3938 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3944 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3948 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3949 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3950 TREE_TYPE (arg
), arg
);
3953 /* Set or clear a single bit. */
3955 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3962 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3963 type
= TREE_TYPE (args
[0]);
3965 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3966 build_int_cst (type
, 1), args
[1]);
3972 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3974 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3977 /* Extract a sequence of bits.
3978 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3980 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3987 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3988 type
= TREE_TYPE (args
[0]);
3990 mask
= build_int_cst (type
, -1);
3991 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3992 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3994 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3996 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4000 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4003 tree args
[2], type
, num_bits
, cond
;
4005 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4007 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4008 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4009 type
= TREE_TYPE (args
[0]);
4012 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4014 gcc_assert (right_shift
);
4016 se
->expr
= fold_build2_loc (input_location
,
4017 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4018 TREE_TYPE (args
[0]), args
[0], args
[1]);
4021 se
->expr
= fold_convert (type
, se
->expr
);
4023 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4024 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4026 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4027 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4030 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4031 build_int_cst (type
, 0), se
->expr
);
4034 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4036 : ((shift >= 0) ? i << shift : i >> -shift)
4037 where all shifts are logical shifts. */
4039 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4051 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4053 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4054 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4056 type
= TREE_TYPE (args
[0]);
4057 utype
= unsigned_type_for (type
);
4059 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4062 /* Left shift if positive. */
4063 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4065 /* Right shift if negative.
4066 We convert to an unsigned type because we want a logical shift.
4067 The standard doesn't define the case of shifting negative
4068 numbers, and we try to be compatible with other compilers, most
4069 notably g77, here. */
4070 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4071 utype
, convert (utype
, args
[0]), width
));
4073 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4074 build_int_cst (TREE_TYPE (args
[1]), 0));
4075 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4077 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4078 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4080 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4081 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4083 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4084 build_int_cst (type
, 0), tmp
);
4088 /* Circular shift. AKA rotate or barrel shift. */
4091 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4099 unsigned int num_args
;
4101 num_args
= gfc_intrinsic_argument_list_length (expr
);
4102 args
= XALLOCAVEC (tree
, num_args
);
4104 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4108 /* Use a library function for the 3 parameter version. */
4109 tree int4type
= gfc_get_int_type (4);
4111 type
= TREE_TYPE (args
[0]);
4112 /* We convert the first argument to at least 4 bytes, and
4113 convert back afterwards. This removes the need for library
4114 functions for all argument sizes, and function will be
4115 aligned to at least 32 bits, so there's no loss. */
4116 if (expr
->ts
.kind
< 4)
4117 args
[0] = convert (int4type
, args
[0]);
4119 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4120 need loads of library functions. They cannot have values >
4121 BIT_SIZE (I) so the conversion is safe. */
4122 args
[1] = convert (int4type
, args
[1]);
4123 args
[2] = convert (int4type
, args
[2]);
4125 switch (expr
->ts
.kind
)
4130 tmp
= gfor_fndecl_math_ishftc4
;
4133 tmp
= gfor_fndecl_math_ishftc8
;
4136 tmp
= gfor_fndecl_math_ishftc16
;
4141 se
->expr
= build_call_expr_loc (input_location
,
4142 tmp
, 3, args
[0], args
[1], args
[2]);
4143 /* Convert the result back to the original type, if we extended
4144 the first argument's width above. */
4145 if (expr
->ts
.kind
< 4)
4146 se
->expr
= convert (type
, se
->expr
);
4150 type
= TREE_TYPE (args
[0]);
4152 /* Evaluate arguments only once. */
4153 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4154 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4156 /* Rotate left if positive. */
4157 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4159 /* Rotate right if negative. */
4160 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4162 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4164 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4165 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4167 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4169 /* Do nothing if shift == 0. */
4170 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4172 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4177 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4178 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4180 The conditional expression is necessary because the result of LEADZ(0)
4181 is defined, but the result of __builtin_clz(0) is undefined for most
4184 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4185 difference in bit size between the argument of LEADZ and the C int. */
4188 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4200 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4201 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4203 /* Which variant of __builtin_clz* should we call? */
4204 if (argsize
<= INT_TYPE_SIZE
)
4206 arg_type
= unsigned_type_node
;
4207 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4209 else if (argsize
<= LONG_TYPE_SIZE
)
4211 arg_type
= long_unsigned_type_node
;
4212 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4214 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4216 arg_type
= long_long_unsigned_type_node
;
4217 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4221 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4222 arg_type
= gfc_build_uint_type (argsize
);
4226 /* Convert the actual argument twice: first, to the unsigned type of the
4227 same size; then, to the proper argument type for the built-in
4228 function. But the return type is of the default INTEGER kind. */
4229 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4230 arg
= fold_convert (arg_type
, arg
);
4231 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4232 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4234 /* Compute LEADZ for the case i .ne. 0. */
4237 s
= TYPE_PRECISION (arg_type
) - argsize
;
4238 tmp
= fold_convert (result_type
,
4239 build_call_expr_loc (input_location
, func
,
4241 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4242 tmp
, build_int_cst (result_type
, s
));
4246 /* We end up here if the argument type is larger than 'long long'.
4247 We generate this code:
4249 if (x & (ULL_MAX << ULL_SIZE) != 0)
4250 return clzll ((unsigned long long) (x >> ULLSIZE));
4252 return ULL_SIZE + clzll ((unsigned long long) x);
4253 where ULL_MAX is the largest value that a ULL_MAX can hold
4254 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4255 is the bit-size of the long long type (64 in this example). */
4256 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4258 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4259 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4260 long_long_unsigned_type_node
,
4261 build_int_cst (long_long_unsigned_type_node
,
4264 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4265 fold_convert (arg_type
, ullmax
), ullsize
);
4266 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4268 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4269 cond
, build_int_cst (arg_type
, 0));
4271 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4273 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4274 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4275 tmp1
= fold_convert (result_type
,
4276 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4278 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4279 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4280 tmp2
= fold_convert (result_type
,
4281 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4282 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4285 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4289 /* Build BIT_SIZE. */
4290 bit_size
= build_int_cst (result_type
, argsize
);
4292 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4293 arg
, build_int_cst (arg_type
, 0));
4294 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4299 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4301 The conditional expression is necessary because the result of TRAILZ(0)
4302 is defined, but the result of __builtin_ctz(0) is undefined for most
4306 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4317 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4318 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4320 /* Which variant of __builtin_ctz* should we call? */
4321 if (argsize
<= INT_TYPE_SIZE
)
4323 arg_type
= unsigned_type_node
;
4324 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4326 else if (argsize
<= LONG_TYPE_SIZE
)
4328 arg_type
= long_unsigned_type_node
;
4329 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4331 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4333 arg_type
= long_long_unsigned_type_node
;
4334 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4338 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4339 arg_type
= gfc_build_uint_type (argsize
);
4343 /* Convert the actual argument twice: first, to the unsigned type of the
4344 same size; then, to the proper argument type for the built-in
4345 function. But the return type is of the default INTEGER kind. */
4346 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4347 arg
= fold_convert (arg_type
, arg
);
4348 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4349 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4351 /* Compute TRAILZ for the case i .ne. 0. */
4353 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4357 /* We end up here if the argument type is larger than 'long long'.
4358 We generate this code:
4360 if ((x & ULL_MAX) == 0)
4361 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4363 return ctzll ((unsigned long long) x);
4365 where ULL_MAX is the largest value that a ULL_MAX can hold
4366 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4367 is the bit-size of the long long type (64 in this example). */
4368 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4370 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4371 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4372 long_long_unsigned_type_node
,
4373 build_int_cst (long_long_unsigned_type_node
, 0));
4375 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4376 fold_convert (arg_type
, ullmax
));
4377 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4378 build_int_cst (arg_type
, 0));
4380 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4382 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4383 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4384 tmp1
= fold_convert (result_type
,
4385 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4386 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4389 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4390 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4391 tmp2
= fold_convert (result_type
,
4392 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4394 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4398 /* Build BIT_SIZE. */
4399 bit_size
= build_int_cst (result_type
, argsize
);
4401 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4402 arg
, build_int_cst (arg_type
, 0));
4403 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4407 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4408 for types larger than "long long", we call the long long built-in for
4409 the lower and higher bits and combine the result. */
4412 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4420 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4421 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4422 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4424 /* Which variant of the builtin should we call? */
4425 if (argsize
<= INT_TYPE_SIZE
)
4427 arg_type
= unsigned_type_node
;
4428 func
= builtin_decl_explicit (parity
4430 : BUILT_IN_POPCOUNT
);
4432 else if (argsize
<= LONG_TYPE_SIZE
)
4434 arg_type
= long_unsigned_type_node
;
4435 func
= builtin_decl_explicit (parity
4437 : BUILT_IN_POPCOUNTL
);
4439 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4441 arg_type
= long_long_unsigned_type_node
;
4442 func
= builtin_decl_explicit (parity
4444 : BUILT_IN_POPCOUNTLL
);
4448 /* Our argument type is larger than 'long long', which mean none
4449 of the POPCOUNT builtins covers it. We thus call the 'long long'
4450 variant multiple times, and add the results. */
4451 tree utype
, arg2
, call1
, call2
;
4453 /* For now, we only cover the case where argsize is twice as large
4455 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4457 func
= builtin_decl_explicit (parity
4459 : BUILT_IN_POPCOUNTLL
);
4461 /* Convert it to an integer, and store into a variable. */
4462 utype
= gfc_build_uint_type (argsize
);
4463 arg
= fold_convert (utype
, arg
);
4464 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4466 /* Call the builtin twice. */
4467 call1
= build_call_expr_loc (input_location
, func
, 1,
4468 fold_convert (long_long_unsigned_type_node
,
4471 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4472 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4473 call2
= build_call_expr_loc (input_location
, func
, 1,
4474 fold_convert (long_long_unsigned_type_node
,
4477 /* Combine the results. */
4479 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4482 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4488 /* Convert the actual argument twice: first, to the unsigned type of the
4489 same size; then, to the proper argument type for the built-in
4491 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4492 arg
= fold_convert (arg_type
, arg
);
4494 se
->expr
= fold_convert (result_type
,
4495 build_call_expr_loc (input_location
, func
, 1, arg
));
4499 /* Process an intrinsic with unspecified argument-types that has an optional
4500 argument (which could be of type character), e.g. EOSHIFT. For those, we
4501 need to append the string length of the optional argument if it is not
4502 present and the type is really character.
4503 primary specifies the position (starting at 1) of the non-optional argument
4504 specifying the type and optional gives the position of the optional
4505 argument in the arglist. */
4508 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4509 unsigned primary
, unsigned optional
)
4511 gfc_actual_arglist
* prim_arg
;
4512 gfc_actual_arglist
* opt_arg
;
4514 gfc_actual_arglist
* arg
;
4516 vec
<tree
, va_gc
> *append_args
;
4518 /* Find the two arguments given as position. */
4522 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4526 if (cur_pos
== primary
)
4528 if (cur_pos
== optional
)
4531 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4534 gcc_assert (prim_arg
);
4535 gcc_assert (prim_arg
->expr
);
4536 gcc_assert (opt_arg
);
4538 /* If we do have type CHARACTER and the optional argument is really absent,
4539 append a dummy 0 as string length. */
4541 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4545 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4546 vec_alloc (append_args
, 1);
4547 append_args
->quick_push (dummy
);
4550 /* Build the call itself. */
4551 sym
= gfc_get_symbol_for_expr (expr
);
4552 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4554 gfc_free_symbol (sym
);
4558 /* The length of a character string. */
4560 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4569 gcc_assert (!se
->ss
);
4571 arg
= expr
->value
.function
.actual
->expr
;
4573 type
= gfc_typenode_for_spec (&expr
->ts
);
4574 switch (arg
->expr_type
)
4577 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4581 /* Obtain the string length from the function used by
4582 trans-array.c(gfc_trans_array_constructor). */
4584 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4588 if (arg
->ref
== NULL
4589 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4591 /* This doesn't catch all cases.
4592 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4593 and the surrounding thread. */
4594 sym
= arg
->symtree
->n
.sym
;
4595 decl
= gfc_get_symbol_decl (sym
);
4596 if (decl
== current_function_decl
&& sym
->attr
.function
4597 && (sym
->result
== sym
))
4598 decl
= gfc_get_fake_result_decl (sym
, 0);
4600 len
= sym
->ts
.u
.cl
->backend_decl
;
4605 /* Otherwise fall through. */
4608 /* Anybody stupid enough to do this deserves inefficient code. */
4609 gfc_init_se (&argse
, se
);
4611 gfc_conv_expr (&argse
, arg
);
4613 gfc_conv_expr_descriptor (&argse
, arg
);
4614 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4615 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4616 len
= argse
.string_length
;
4619 se
->expr
= convert (type
, len
);
4622 /* The length of a character string not including trailing blanks. */
4624 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4626 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4627 tree args
[2], type
, fndecl
;
4629 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4630 type
= gfc_typenode_for_spec (&expr
->ts
);
4633 fndecl
= gfor_fndecl_string_len_trim
;
4635 fndecl
= gfor_fndecl_string_len_trim_char4
;
4639 se
->expr
= build_call_expr_loc (input_location
,
4640 fndecl
, 2, args
[0], args
[1]);
4641 se
->expr
= convert (type
, se
->expr
);
4645 /* Returns the starting position of a substring within a string. */
4648 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4651 tree logical4_type_node
= gfc_get_logical_type (4);
4655 unsigned int num_args
;
4657 args
= XALLOCAVEC (tree
, 5);
4659 /* Get number of arguments; characters count double due to the
4660 string length argument. Kind= is not passed to the library
4661 and thus ignored. */
4662 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4667 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4668 type
= gfc_typenode_for_spec (&expr
->ts
);
4671 args
[4] = build_int_cst (logical4_type_node
, 0);
4673 args
[4] = convert (logical4_type_node
, args
[4]);
4675 fndecl
= build_addr (function
, current_function_decl
);
4676 se
->expr
= build_call_array_loc (input_location
,
4677 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4679 se
->expr
= convert (type
, se
->expr
);
4683 /* The ascii value for a single character. */
4685 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4687 tree args
[2], type
, pchartype
;
4689 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4690 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4691 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4692 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4693 type
= gfc_typenode_for_spec (&expr
->ts
);
4695 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4697 se
->expr
= convert (type
, se
->expr
);
4701 /* Intrinsic ISNAN calls __builtin_isnan. */
4704 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4708 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4709 se
->expr
= build_call_expr_loc (input_location
,
4710 builtin_decl_explicit (BUILT_IN_ISNAN
),
4712 STRIP_TYPE_NOPS (se
->expr
);
4713 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4717 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4718 their argument against a constant integer value. */
4721 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4725 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4726 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4727 gfc_typenode_for_spec (&expr
->ts
),
4728 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4733 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4736 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4744 unsigned int num_args
;
4746 num_args
= gfc_intrinsic_argument_list_length (expr
);
4747 args
= XALLOCAVEC (tree
, num_args
);
4749 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4750 if (expr
->ts
.type
!= BT_CHARACTER
)
4758 /* We do the same as in the non-character case, but the argument
4759 list is different because of the string length arguments. We
4760 also have to set the string length for the result. */
4767 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4769 se
->string_length
= len
;
4771 type
= TREE_TYPE (tsource
);
4772 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4773 fold_convert (type
, fsource
));
4777 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4780 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4782 tree args
[3], mask
, type
;
4784 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4785 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4787 type
= TREE_TYPE (args
[0]);
4788 gcc_assert (TREE_TYPE (args
[1]) == type
);
4789 gcc_assert (TREE_TYPE (mask
) == type
);
4791 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4792 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4793 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4795 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4800 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4801 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4804 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4806 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4809 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4810 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4812 type
= gfc_get_int_type (expr
->ts
.kind
);
4813 utype
= unsigned_type_for (type
);
4815 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4816 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4818 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4819 build_int_cst (utype
, 0));
4823 /* Left-justified mask. */
4824 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4826 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4827 fold_convert (utype
, res
));
4829 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4830 smaller than type width. */
4831 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4832 build_int_cst (TREE_TYPE (arg
), 0));
4833 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4834 build_int_cst (utype
, 0), res
);
4838 /* Right-justified mask. */
4839 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4840 fold_convert (utype
, arg
));
4841 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4843 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4844 strictly smaller than type width. */
4845 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4847 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4848 cond
, allones
, res
);
4851 se
->expr
= fold_convert (type
, res
);
4855 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4857 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4859 tree arg
, type
, tmp
, frexp
;
4861 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4863 type
= gfc_typenode_for_spec (&expr
->ts
);
4864 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4865 tmp
= gfc_create_var (integer_type_node
, NULL
);
4866 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4867 fold_convert (type
, arg
),
4868 gfc_build_addr_expr (NULL_TREE
, tmp
));
4869 se
->expr
= fold_convert (type
, se
->expr
);
4873 /* NEAREST (s, dir) is translated into
4874 tmp = copysign (HUGE_VAL, dir);
4875 return nextafter (s, tmp);
4878 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4880 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4882 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4883 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4885 type
= gfc_typenode_for_spec (&expr
->ts
);
4886 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4888 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4889 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4890 fold_convert (type
, args
[1]));
4891 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4892 fold_convert (type
, args
[0]), tmp
);
4893 se
->expr
= fold_convert (type
, se
->expr
);
4897 /* SPACING (s) is translated into
4905 e = MAX_EXPR (e, emin);
4906 res = scalbn (1., e);
4910 where prec is the precision of s, gfc_real_kinds[k].digits,
4911 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4912 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4915 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4917 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4918 tree cond
, tmp
, frexp
, scalbn
;
4922 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4923 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
4924 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
4925 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4927 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4928 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4930 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4931 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4933 type
= gfc_typenode_for_spec (&expr
->ts
);
4934 e
= gfc_create_var (integer_type_node
, NULL
);
4935 res
= gfc_create_var (type
, NULL
);
4938 /* Build the block for s /= 0. */
4939 gfc_start_block (&block
);
4940 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4941 gfc_build_addr_expr (NULL_TREE
, e
));
4942 gfc_add_expr_to_block (&block
, tmp
);
4944 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4946 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4947 integer_type_node
, tmp
, emin
));
4949 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4950 build_real_from_int_cst (type
, integer_one_node
), e
);
4951 gfc_add_modify (&block
, res
, tmp
);
4953 /* Finish by building the IF statement. */
4954 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4955 build_real_from_int_cst (type
, integer_zero_node
));
4956 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4957 gfc_finish_block (&block
));
4959 gfc_add_expr_to_block (&se
->pre
, tmp
);
4964 /* RRSPACING (s) is translated into
4971 x = scalbn (x, precision - e);
4975 where precision is gfc_real_kinds[k].digits. */
4978 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4980 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4984 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4985 prec
= gfc_real_kinds
[k
].digits
;
4987 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4988 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4989 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4991 type
= gfc_typenode_for_spec (&expr
->ts
);
4992 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4993 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4995 e
= gfc_create_var (integer_type_node
, NULL
);
4996 x
= gfc_create_var (type
, NULL
);
4997 gfc_add_modify (&se
->pre
, x
,
4998 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5001 gfc_start_block (&block
);
5002 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5003 gfc_build_addr_expr (NULL_TREE
, e
));
5004 gfc_add_expr_to_block (&block
, tmp
);
5006 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5007 build_int_cst (integer_type_node
, prec
), e
);
5008 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5009 gfc_add_modify (&block
, x
, tmp
);
5010 stmt
= gfc_finish_block (&block
);
5012 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5013 build_real_from_int_cst (type
, integer_zero_node
));
5014 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5015 gfc_add_expr_to_block (&se
->pre
, tmp
);
5017 se
->expr
= fold_convert (type
, x
);
5021 /* SCALE (s, i) is translated into scalbn (s, i). */
5023 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5025 tree args
[2], type
, scalbn
;
5027 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5029 type
= gfc_typenode_for_spec (&expr
->ts
);
5030 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5031 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5032 fold_convert (type
, args
[0]),
5033 fold_convert (integer_type_node
, args
[1]));
5034 se
->expr
= fold_convert (type
, se
->expr
);
5038 /* SET_EXPONENT (s, i) is translated into
5039 scalbn (frexp (s, &dummy_int), i). */
5041 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5043 tree args
[2], type
, tmp
, frexp
, scalbn
;
5045 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5046 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5048 type
= gfc_typenode_for_spec (&expr
->ts
);
5049 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5051 tmp
= gfc_create_var (integer_type_node
, NULL
);
5052 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5053 fold_convert (type
, args
[0]),
5054 gfc_build_addr_expr (NULL_TREE
, tmp
));
5055 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5056 fold_convert (integer_type_node
, args
[1]));
5057 se
->expr
= fold_convert (type
, se
->expr
);
5062 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5064 gfc_actual_arglist
*actual
;
5071 gfc_init_se (&argse
, NULL
);
5072 actual
= expr
->value
.function
.actual
;
5074 if (actual
->expr
->ts
.type
== BT_CLASS
)
5075 gfc_add_class_array_ref (actual
->expr
);
5077 argse
.want_pointer
= 1;
5078 argse
.data_not_needed
= 1;
5079 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5080 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5081 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5082 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5084 /* Build the call to size0. */
5085 fncall0
= build_call_expr_loc (input_location
,
5086 gfor_fndecl_size0
, 1, arg1
);
5088 actual
= actual
->next
;
5092 gfc_init_se (&argse
, NULL
);
5093 gfc_conv_expr_type (&argse
, actual
->expr
,
5094 gfc_array_index_type
);
5095 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5097 /* Unusually, for an intrinsic, size does not exclude
5098 an optional arg2, so we must test for it. */
5099 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5100 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5101 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5104 /* Build the call to size1. */
5105 fncall1
= build_call_expr_loc (input_location
,
5106 gfor_fndecl_size1
, 2,
5109 gfc_init_se (&argse
, NULL
);
5110 argse
.want_pointer
= 1;
5111 argse
.data_not_needed
= 1;
5112 gfc_conv_expr (&argse
, actual
->expr
);
5113 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5114 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5115 argse
.expr
, null_pointer_node
);
5116 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5117 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5118 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5122 se
->expr
= NULL_TREE
;
5123 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5124 gfc_array_index_type
,
5125 argse
.expr
, gfc_index_one_node
);
5128 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5130 argse
.expr
= gfc_index_zero_node
;
5131 se
->expr
= NULL_TREE
;
5136 if (se
->expr
== NULL_TREE
)
5138 tree ubound
, lbound
;
5140 arg1
= build_fold_indirect_ref_loc (input_location
,
5142 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5143 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5144 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5145 gfc_array_index_type
, ubound
, lbound
);
5146 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5147 gfc_array_index_type
,
5148 se
->expr
, gfc_index_one_node
);
5149 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5150 gfc_array_index_type
, se
->expr
,
5151 gfc_index_zero_node
);
5154 type
= gfc_typenode_for_spec (&expr
->ts
);
5155 se
->expr
= convert (type
, se
->expr
);
5159 /* Helper function to compute the size of a character variable,
5160 excluding the terminating null characters. The result has
5161 gfc_array_index_type type. */
5164 size_of_string_in_bytes (int kind
, tree string_length
)
5167 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5169 bytesize
= build_int_cst (gfc_array_index_type
,
5170 gfc_character_kinds
[i
].bit_size
/ 8);
5172 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5174 fold_convert (gfc_array_index_type
, string_length
));
5179 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5190 arg
= expr
->value
.function
.actual
->expr
;
5192 gfc_init_se (&argse
, NULL
);
5196 if (arg
->ts
.type
== BT_CLASS
)
5197 gfc_add_data_component (arg
);
5199 gfc_conv_expr_reference (&argse
, arg
);
5201 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5204 /* Obtain the source word length. */
5205 if (arg
->ts
.type
== BT_CHARACTER
)
5206 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5207 argse
.string_length
);
5209 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5213 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5214 argse
.want_pointer
= 0;
5215 gfc_conv_expr_descriptor (&argse
, arg
);
5216 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5218 /* Obtain the argument's word length. */
5219 if (arg
->ts
.type
== BT_CHARACTER
)
5220 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5222 tmp
= fold_convert (gfc_array_index_type
,
5223 size_in_bytes (type
));
5224 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5226 /* Obtain the size of the array in bytes. */
5227 for (n
= 0; n
< arg
->rank
; n
++)
5230 idx
= gfc_rank_cst
[n
];
5231 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5232 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5233 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5234 gfc_array_index_type
, upper
, lower
);
5235 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5236 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5237 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5238 gfc_array_index_type
, tmp
, source_bytes
);
5239 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5241 se
->expr
= source_bytes
;
5244 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5249 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5253 tree type
, result_type
, tmp
;
5255 arg
= expr
->value
.function
.actual
->expr
;
5257 gfc_init_se (&argse
, NULL
);
5258 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5262 if (arg
->ts
.type
== BT_CLASS
)
5264 gfc_add_vptr_component (arg
);
5265 gfc_add_size_component (arg
);
5266 gfc_conv_expr (&argse
, arg
);
5267 tmp
= fold_convert (result_type
, argse
.expr
);
5271 gfc_conv_expr_reference (&argse
, arg
);
5272 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5277 argse
.want_pointer
= 0;
5278 gfc_conv_expr_descriptor (&argse
, arg
);
5279 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5282 /* Obtain the argument's word length. */
5283 if (arg
->ts
.type
== BT_CHARACTER
)
5284 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5286 tmp
= size_in_bytes (type
);
5287 tmp
= fold_convert (result_type
, tmp
);
5290 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5291 build_int_cst (result_type
, BITS_PER_UNIT
));
5292 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5296 /* Intrinsic string comparison functions. */
5299 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5303 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5306 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5307 expr
->value
.function
.actual
->expr
->ts
.kind
,
5309 se
->expr
= fold_build2_loc (input_location
, op
,
5310 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5311 build_int_cst (TREE_TYPE (se
->expr
), 0));
5314 /* Generate a call to the adjustl/adjustr library function. */
5316 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5324 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5327 type
= TREE_TYPE (args
[2]);
5328 var
= gfc_conv_string_tmp (se
, type
, len
);
5331 tmp
= build_call_expr_loc (input_location
,
5332 fndecl
, 3, args
[0], args
[1], args
[2]);
5333 gfc_add_expr_to_block (&se
->pre
, tmp
);
5335 se
->string_length
= len
;
5339 /* Generate code for the TRANSFER intrinsic:
5341 DEST = TRANSFER (SOURCE, MOLD)
5343 typeof<DEST> = typeof<MOLD>
5348 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5350 typeof<DEST> = typeof<MOLD>
5352 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5353 sizeof (DEST(0) * SIZE). */
5355 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5371 gfc_actual_arglist
*arg
;
5373 gfc_array_info
*info
;
5377 gfc_expr
*source_expr
, *mold_expr
;
5381 info
= &se
->ss
->info
->data
.array
;
5383 /* Convert SOURCE. The output from this stage is:-
5384 source_bytes = length of the source in bytes
5385 source = pointer to the source data. */
5386 arg
= expr
->value
.function
.actual
;
5387 source_expr
= arg
->expr
;
5389 /* Ensure double transfer through LOGICAL preserves all
5391 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5392 && arg
->expr
->value
.function
.esym
== NULL
5393 && arg
->expr
->value
.function
.isym
!= NULL
5394 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5395 && arg
->expr
->ts
.type
== BT_LOGICAL
5396 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5397 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5399 gfc_init_se (&argse
, NULL
);
5401 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5403 /* Obtain the pointer to source and the length of source in bytes. */
5404 if (arg
->expr
->rank
== 0)
5406 gfc_conv_expr_reference (&argse
, arg
->expr
);
5407 if (arg
->expr
->ts
.type
== BT_CLASS
)
5408 source
= gfc_class_data_get (argse
.expr
);
5410 source
= argse
.expr
;
5412 /* Obtain the source word length. */
5413 switch (arg
->expr
->ts
.type
)
5416 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5417 argse
.string_length
);
5420 tmp
= gfc_vtable_size_get (argse
.expr
);
5423 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5425 tmp
= fold_convert (gfc_array_index_type
,
5426 size_in_bytes (source_type
));
5432 argse
.want_pointer
= 0;
5433 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5434 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5435 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5437 /* Repack the source if not simply contiguous. */
5438 if (!gfc_is_simply_contiguous (arg
->expr
, false))
5440 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5442 if (gfc_option
.warn_array_temp
)
5443 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5445 source
= build_call_expr_loc (input_location
,
5446 gfor_fndecl_in_pack
, 1, tmp
);
5447 source
= gfc_evaluate_now (source
, &argse
.pre
);
5449 /* Free the temporary. */
5450 gfc_start_block (&block
);
5451 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5452 gfc_add_expr_to_block (&block
, tmp
);
5453 stmt
= gfc_finish_block (&block
);
5455 /* Clean up if it was repacked. */
5456 gfc_init_block (&block
);
5457 tmp
= gfc_conv_array_data (argse
.expr
);
5458 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5460 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5461 build_empty_stmt (input_location
));
5462 gfc_add_expr_to_block (&block
, tmp
);
5463 gfc_add_block_to_block (&block
, &se
->post
);
5464 gfc_init_block (&se
->post
);
5465 gfc_add_block_to_block (&se
->post
, &block
);
5468 /* Obtain the source word length. */
5469 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5470 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5471 argse
.string_length
);
5473 tmp
= fold_convert (gfc_array_index_type
,
5474 size_in_bytes (source_type
));
5476 /* Obtain the size of the array in bytes. */
5477 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5478 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5481 idx
= gfc_rank_cst
[n
];
5482 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5483 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5484 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5485 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5486 gfc_array_index_type
, upper
, lower
);
5487 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5488 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5489 gfc_array_index_type
, extent
,
5490 gfc_index_one_node
);
5491 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5492 gfc_array_index_type
, tmp
, source_bytes
);
5496 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5497 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5498 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5500 /* Now convert MOLD. The outputs are:
5501 mold_type = the TREE type of MOLD
5502 dest_word_len = destination word length in bytes. */
5504 mold_expr
= arg
->expr
;
5506 gfc_init_se (&argse
, NULL
);
5508 scalar_mold
= arg
->expr
->rank
== 0;
5510 if (arg
->expr
->rank
== 0)
5512 gfc_conv_expr_reference (&argse
, arg
->expr
);
5513 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5518 gfc_init_se (&argse
, NULL
);
5519 argse
.want_pointer
= 0;
5520 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5521 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5524 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5525 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5527 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5529 /* If this TRANSFER is nested in another TRANSFER, use a type
5530 that preserves all bits. */
5531 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5532 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5535 /* Obtain the destination word length. */
5536 switch (arg
->expr
->ts
.type
)
5539 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5540 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5543 tmp
= gfc_vtable_size_get (argse
.expr
);
5546 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
5549 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5550 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5552 /* Finally convert SIZE, if it is present. */
5554 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5558 gfc_init_se (&argse
, NULL
);
5559 gfc_conv_expr_reference (&argse
, arg
->expr
);
5560 tmp
= convert (gfc_array_index_type
,
5561 build_fold_indirect_ref_loc (input_location
,
5563 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5564 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5569 /* Separate array and scalar results. */
5570 if (scalar_mold
&& tmp
== NULL_TREE
)
5571 goto scalar_transfer
;
5573 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5574 if (tmp
!= NULL_TREE
)
5575 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5576 tmp
, dest_word_len
);
5580 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5581 gfc_add_modify (&se
->pre
, size_words
,
5582 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5583 gfc_array_index_type
,
5584 size_bytes
, dest_word_len
));
5586 /* Evaluate the bounds of the result. If the loop range exists, we have
5587 to check if it is too large. If so, we modify loop->to be consistent
5588 with min(size, size(source)). Otherwise, size is made consistent with
5589 the loop range, so that the right number of bytes is transferred.*/
5590 n
= se
->loop
->order
[0];
5591 if (se
->loop
->to
[n
] != NULL_TREE
)
5593 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5594 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5595 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5596 tmp
, gfc_index_one_node
);
5597 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5599 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5600 gfc_add_modify (&se
->pre
, size_bytes
,
5601 fold_build2_loc (input_location
, MULT_EXPR
,
5602 gfc_array_index_type
,
5603 size_words
, dest_word_len
));
5604 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5605 size_words
, se
->loop
->from
[n
]);
5606 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5607 upper
, gfc_index_one_node
);
5611 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5612 size_words
, gfc_index_one_node
);
5613 se
->loop
->from
[n
] = gfc_index_zero_node
;
5616 se
->loop
->to
[n
] = upper
;
5618 /* Build a destination descriptor, using the pointer, source, as the
5620 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5621 NULL_TREE
, false, true, false, &expr
->where
);
5623 /* Cast the pointer to the result. */
5624 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5625 tmp
= fold_convert (pvoid_type_node
, tmp
);
5627 /* Use memcpy to do the transfer. */
5629 = build_call_expr_loc (input_location
,
5630 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
5631 fold_convert (pvoid_type_node
, source
),
5632 fold_convert (size_type_node
,
5633 fold_build2_loc (input_location
,
5635 gfc_array_index_type
,
5638 gfc_add_expr_to_block (&se
->pre
, tmp
);
5640 se
->expr
= info
->descriptor
;
5641 if (expr
->ts
.type
== BT_CHARACTER
)
5642 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5646 /* Deal with scalar results. */
5648 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5649 dest_word_len
, source_bytes
);
5650 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5651 extent
, gfc_index_zero_node
);
5653 if (expr
->ts
.type
== BT_CHARACTER
)
5655 tree direct
, indirect
, free
;
5657 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5658 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5661 /* If source is longer than the destination, use a pointer to
5662 the source directly. */
5663 gfc_init_block (&block
);
5664 gfc_add_modify (&block
, tmpdecl
, ptr
);
5665 direct
= gfc_finish_block (&block
);
5667 /* Otherwise, allocate a string with the length of the destination
5668 and copy the source into it. */
5669 gfc_init_block (&block
);
5670 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5671 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5672 gfc_add_modify (&block
, tmpdecl
,
5673 fold_convert (TREE_TYPE (ptr
), tmp
));
5674 tmp
= build_call_expr_loc (input_location
,
5675 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5676 fold_convert (pvoid_type_node
, tmpdecl
),
5677 fold_convert (pvoid_type_node
, ptr
),
5678 fold_convert (size_type_node
, extent
));
5679 gfc_add_expr_to_block (&block
, tmp
);
5680 indirect
= gfc_finish_block (&block
);
5682 /* Wrap it up with the condition. */
5683 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5684 dest_word_len
, source_bytes
);
5685 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5686 gfc_add_expr_to_block (&se
->pre
, tmp
);
5688 /* Free the temporary string, if necessary. */
5689 free
= gfc_call_free (tmpdecl
);
5690 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5691 dest_word_len
, source_bytes
);
5692 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
5693 gfc_add_expr_to_block (&se
->post
, tmp
);
5696 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5700 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5702 ptr
= convert (build_pointer_type (mold_type
), source
);
5704 /* For CLASS results, allocate the needed memory first. */
5705 if (mold_expr
->ts
.type
== BT_CLASS
)
5708 cdata
= gfc_class_data_get (tmpdecl
);
5709 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
5710 gfc_add_modify (&se
->pre
, cdata
, tmp
);
5713 /* Use memcpy to do the transfer. */
5714 if (mold_expr
->ts
.type
== BT_CLASS
)
5715 tmp
= gfc_class_data_get (tmpdecl
);
5717 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5719 tmp
= build_call_expr_loc (input_location
,
5720 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5721 fold_convert (pvoid_type_node
, tmp
),
5722 fold_convert (pvoid_type_node
, ptr
),
5723 fold_convert (size_type_node
, extent
));
5724 gfc_add_expr_to_block (&se
->pre
, tmp
);
5726 /* For CLASS results, set the _vptr. */
5727 if (mold_expr
->ts
.type
== BT_CLASS
)
5731 vptr
= gfc_class_vptr_get (tmpdecl
);
5732 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
5734 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
5735 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
5743 /* Generate code for the ALLOCATED intrinsic.
5744 Generate inline code that directly check the address of the argument. */
5747 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5749 gfc_actual_arglist
*arg1
;
5753 gfc_init_se (&arg1se
, NULL
);
5754 arg1
= expr
->value
.function
.actual
;
5756 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5758 /* Make sure that class array expressions have both a _data
5759 component reference and an array reference.... */
5760 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5761 gfc_add_class_array_ref (arg1
->expr
);
5762 /* .... whilst scalars only need the _data component. */
5764 gfc_add_data_component (arg1
->expr
);
5767 if (arg1
->expr
->rank
== 0)
5769 /* Allocatable scalar. */
5770 arg1se
.want_pointer
= 1;
5771 gfc_conv_expr (&arg1se
, arg1
->expr
);
5776 /* Allocatable array. */
5777 arg1se
.descriptor_only
= 1;
5778 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5779 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5782 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5783 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5784 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5788 /* Generate code for the ASSOCIATED intrinsic.
5789 If both POINTER and TARGET are arrays, generate a call to library function
5790 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5791 In other cases, generate inline code that directly compare the address of
5792 POINTER with the address of TARGET. */
5795 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5797 gfc_actual_arglist
*arg1
;
5798 gfc_actual_arglist
*arg2
;
5803 tree nonzero_charlen
;
5804 tree nonzero_arraylen
;
5808 gfc_init_se (&arg1se
, NULL
);
5809 gfc_init_se (&arg2se
, NULL
);
5810 arg1
= expr
->value
.function
.actual
;
5813 /* Check whether the expression is a scalar or not; we cannot use
5814 arg1->expr->rank as it can be nonzero for proc pointers. */
5815 ss
= gfc_walk_expr (arg1
->expr
);
5816 scalar
= ss
== gfc_ss_terminator
;
5818 gfc_free_ss_chain (ss
);
5822 /* No optional target. */
5825 /* A pointer to a scalar. */
5826 arg1se
.want_pointer
= 1;
5827 gfc_conv_expr (&arg1se
, arg1
->expr
);
5828 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5829 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5830 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5832 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5833 tmp2
= gfc_class_data_get (arg1se
.expr
);
5839 /* A pointer to an array. */
5840 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5841 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5843 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5844 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5845 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5846 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5851 /* An optional target. */
5852 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5853 gfc_add_data_component (arg2
->expr
);
5855 nonzero_charlen
= NULL_TREE
;
5856 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5857 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5859 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5863 /* A pointer to a scalar. */
5864 arg1se
.want_pointer
= 1;
5865 gfc_conv_expr (&arg1se
, arg1
->expr
);
5866 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5867 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5868 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5870 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5871 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
5873 arg2se
.want_pointer
= 1;
5874 gfc_conv_expr (&arg2se
, arg2
->expr
);
5875 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5876 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
5877 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
5879 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5880 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5881 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5882 arg1se
.expr
, arg2se
.expr
);
5883 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5884 arg1se
.expr
, null_pointer_node
);
5885 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5886 boolean_type_node
, tmp
, tmp2
);
5890 /* An array pointer of zero length is not associated if target is
5892 arg1se
.descriptor_only
= 1;
5893 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5894 if (arg1
->expr
->rank
== -1)
5896 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
5897 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5898 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
5901 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
5902 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
5903 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5904 boolean_type_node
, tmp
,
5905 build_int_cst (TREE_TYPE (tmp
), 0));
5907 /* A pointer to an array, call library function _gfor_associated. */
5908 arg1se
.want_pointer
= 1;
5909 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5911 arg2se
.want_pointer
= 1;
5912 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
5913 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5914 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5915 se
->expr
= build_call_expr_loc (input_location
,
5916 gfor_fndecl_associated
, 2,
5917 arg1se
.expr
, arg2se
.expr
);
5918 se
->expr
= convert (boolean_type_node
, se
->expr
);
5919 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5920 boolean_type_node
, se
->expr
,
5924 /* If target is present zero character length pointers cannot
5926 if (nonzero_charlen
!= NULL_TREE
)
5927 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5929 se
->expr
, nonzero_charlen
);
5932 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5936 /* Generate code for the SAME_TYPE_AS intrinsic.
5937 Generate inline code that directly checks the vindices. */
5940 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5945 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
5947 gfc_init_se (&se1
, NULL
);
5948 gfc_init_se (&se2
, NULL
);
5950 a
= expr
->value
.function
.actual
->expr
;
5951 b
= expr
->value
.function
.actual
->next
->expr
;
5953 if (UNLIMITED_POLY (a
))
5955 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
5956 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5957 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5960 if (UNLIMITED_POLY (b
))
5962 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
5963 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5964 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5967 if (a
->ts
.type
== BT_CLASS
)
5969 gfc_add_vptr_component (a
);
5970 gfc_add_hash_component (a
);
5972 else if (a
->ts
.type
== BT_DERIVED
)
5973 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5974 a
->ts
.u
.derived
->hash_value
);
5976 if (b
->ts
.type
== BT_CLASS
)
5978 gfc_add_vptr_component (b
);
5979 gfc_add_hash_component (b
);
5981 else if (b
->ts
.type
== BT_DERIVED
)
5982 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5983 b
->ts
.u
.derived
->hash_value
);
5985 gfc_conv_expr (&se1
, a
);
5986 gfc_conv_expr (&se2
, b
);
5988 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5989 boolean_type_node
, se1
.expr
,
5990 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5993 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5994 boolean_type_node
, conda
, tmp
);
5997 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5998 boolean_type_node
, condb
, tmp
);
6000 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6004 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6007 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6011 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6012 se
->expr
= build_call_expr_loc (input_location
,
6013 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6014 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6018 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6021 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6025 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6027 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6028 type
= gfc_get_int_type (4);
6029 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6031 /* Convert it to the required type. */
6032 type
= gfc_typenode_for_spec (&expr
->ts
);
6033 se
->expr
= build_call_expr_loc (input_location
,
6034 gfor_fndecl_si_kind
, 1, arg
);
6035 se
->expr
= fold_convert (type
, se
->expr
);
6039 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6042 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6044 gfc_actual_arglist
*actual
;
6047 vec
<tree
, va_gc
> *args
= NULL
;
6049 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6051 gfc_init_se (&argse
, se
);
6053 /* Pass a NULL pointer for an absent arg. */
6054 if (actual
->expr
== NULL
)
6055 argse
.expr
= null_pointer_node
;
6061 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6063 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6064 ts
.type
= BT_INTEGER
;
6065 ts
.kind
= gfc_c_int_kind
;
6066 gfc_convert_type (actual
->expr
, &ts
, 2);
6068 gfc_conv_expr_reference (&argse
, actual
->expr
);
6071 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6072 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6073 vec_safe_push (args
, argse
.expr
);
6076 /* Convert it to the required type. */
6077 type
= gfc_typenode_for_spec (&expr
->ts
);
6078 se
->expr
= build_call_expr_loc_vec (input_location
,
6079 gfor_fndecl_sr_kind
, args
);
6080 se
->expr
= fold_convert (type
, se
->expr
);
6084 /* Generate code for TRIM (A) intrinsic function. */
6087 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6097 unsigned int num_args
;
6099 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6100 args
= XALLOCAVEC (tree
, num_args
);
6102 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6103 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6104 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6106 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6107 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6110 if (expr
->ts
.kind
== 1)
6111 function
= gfor_fndecl_string_trim
;
6112 else if (expr
->ts
.kind
== 4)
6113 function
= gfor_fndecl_string_trim_char4
;
6117 fndecl
= build_addr (function
, current_function_decl
);
6118 tmp
= build_call_array_loc (input_location
,
6119 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6121 gfc_add_expr_to_block (&se
->pre
, tmp
);
6123 /* Free the temporary afterwards, if necessary. */
6124 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6125 len
, build_int_cst (TREE_TYPE (len
), 0));
6126 tmp
= gfc_call_free (var
);
6127 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6128 gfc_add_expr_to_block (&se
->post
, tmp
);
6131 se
->string_length
= len
;
6135 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6138 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6140 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6141 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6143 stmtblock_t block
, body
;
6146 /* We store in charsize the size of a character. */
6147 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6148 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6150 /* Get the arguments. */
6151 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6152 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6154 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6155 ncopies_type
= TREE_TYPE (ncopies
);
6157 /* Check that NCOPIES is not negative. */
6158 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6159 build_int_cst (ncopies_type
, 0));
6160 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6161 "Argument NCOPIES of REPEAT intrinsic is negative "
6162 "(its value is %ld)",
6163 fold_convert (long_integer_type_node
, ncopies
));
6165 /* If the source length is zero, any non negative value of NCOPIES
6166 is valid, and nothing happens. */
6167 n
= gfc_create_var (ncopies_type
, "ncopies");
6168 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6169 build_int_cst (size_type_node
, 0));
6170 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6171 build_int_cst (ncopies_type
, 0), ncopies
);
6172 gfc_add_modify (&se
->pre
, n
, tmp
);
6175 /* Check that ncopies is not too large: ncopies should be less than
6176 (or equal to) MAX / slen, where MAX is the maximal integer of
6177 the gfc_charlen_type_node type. If slen == 0, we need a special
6178 case to avoid the division by zero. */
6179 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6180 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6181 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6182 fold_convert (size_type_node
, max
), slen
);
6183 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6184 ? size_type_node
: ncopies_type
;
6185 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6186 fold_convert (largest
, ncopies
),
6187 fold_convert (largest
, max
));
6188 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6189 build_int_cst (size_type_node
, 0));
6190 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6191 boolean_false_node
, cond
);
6192 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6193 "Argument NCOPIES of REPEAT intrinsic is too large");
6195 /* Compute the destination length. */
6196 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6197 fold_convert (gfc_charlen_type_node
, slen
),
6198 fold_convert (gfc_charlen_type_node
, ncopies
));
6199 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6200 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6202 /* Generate the code to do the repeat operation:
6203 for (i = 0; i < ncopies; i++)
6204 memmove (dest + (i * slen * size), src, slen*size); */
6205 gfc_start_block (&block
);
6206 count
= gfc_create_var (ncopies_type
, "count");
6207 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6208 exit_label
= gfc_build_label_decl (NULL_TREE
);
6210 /* Start the loop body. */
6211 gfc_start_block (&body
);
6213 /* Exit the loop if count >= ncopies. */
6214 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6216 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6217 TREE_USED (exit_label
) = 1;
6218 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6219 build_empty_stmt (input_location
));
6220 gfc_add_expr_to_block (&body
, tmp
);
6222 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6223 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6224 fold_convert (gfc_charlen_type_node
, slen
),
6225 fold_convert (gfc_charlen_type_node
, count
));
6226 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6227 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6228 tmp
= fold_build_pointer_plus_loc (input_location
,
6229 fold_convert (pvoid_type_node
, dest
), tmp
);
6230 tmp
= build_call_expr_loc (input_location
,
6231 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6233 fold_build2_loc (input_location
, MULT_EXPR
,
6234 size_type_node
, slen
,
6235 fold_convert (size_type_node
,
6237 gfc_add_expr_to_block (&body
, tmp
);
6239 /* Increment count. */
6240 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6241 count
, build_int_cst (TREE_TYPE (count
), 1));
6242 gfc_add_modify (&body
, count
, tmp
);
6244 /* Build the loop. */
6245 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6246 gfc_add_expr_to_block (&block
, tmp
);
6248 /* Add the exit label. */
6249 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6250 gfc_add_expr_to_block (&block
, tmp
);
6252 /* Finish the block. */
6253 tmp
= gfc_finish_block (&block
);
6254 gfc_add_expr_to_block (&se
->pre
, tmp
);
6256 /* Set the result value. */
6258 se
->string_length
= dlen
;
6262 /* Generate code for the IARGC intrinsic. */
6265 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6271 /* Call the library function. This always returns an INTEGER(4). */
6272 fndecl
= gfor_fndecl_iargc
;
6273 tmp
= build_call_expr_loc (input_location
,
6276 /* Convert it to the required type. */
6277 type
= gfc_typenode_for_spec (&expr
->ts
);
6278 tmp
= fold_convert (type
, tmp
);
6284 /* The loc intrinsic returns the address of its argument as
6285 gfc_index_integer_kind integer. */
6288 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6293 gcc_assert (!se
->ss
);
6295 arg_expr
= expr
->value
.function
.actual
->expr
;
6296 if (arg_expr
->rank
== 0)
6297 gfc_conv_expr_reference (se
, arg_expr
);
6299 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
6300 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6302 /* Create a temporary variable for loc return value. Without this,
6303 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6304 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6305 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6306 se
->expr
= temp_var
;
6310 /* The following routine generates code for the intrinsic
6311 functions from the ISO_C_BINDING module:
6317 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
6319 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
6321 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
6323 if (arg
->expr
->rank
== 0)
6324 gfc_conv_expr_reference (se
, arg
->expr
);
6325 else if (gfc_is_simply_contiguous (arg
->expr
, false))
6326 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
6329 gfc_conv_expr_descriptor (se
, arg
->expr
);
6330 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
6333 /* TODO -- the following two lines shouldn't be necessary, but if
6334 they're removed, a bug is exposed later in the code path.
6335 This workaround was thus introduced, but will have to be
6336 removed; please see PR 35150 for details about the issue. */
6337 se
->expr
= convert (pvoid_type_node
, se
->expr
);
6338 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6340 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
6341 gfc_conv_expr_reference (se
, arg
->expr
);
6342 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
6347 /* Build the addr_expr for the first argument. The argument is
6348 already an *address* so we don't need to set want_pointer in
6350 gfc_init_se (&arg1se
, NULL
);
6351 gfc_conv_expr (&arg1se
, arg
->expr
);
6352 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6353 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6355 /* See if we were given two arguments. */
6356 if (arg
->next
->expr
== NULL
)
6357 /* Only given one arg so generate a null and do a
6358 not-equal comparison against the first arg. */
6359 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6361 fold_convert (TREE_TYPE (arg1se
.expr
),
6362 null_pointer_node
));
6368 /* Given two arguments so build the arg2se from second arg. */
6369 gfc_init_se (&arg2se
, NULL
);
6370 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
6371 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6372 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6374 /* Generate test to compare that the two args are equal. */
6375 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6376 arg1se
.expr
, arg2se
.expr
);
6377 /* Generate test to ensure that the first arg is not null. */
6378 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
6380 arg1se
.expr
, null_pointer_node
);
6382 /* Finally, the generated test must check that both arg1 is not
6383 NULL and that it is equal to the second arg. */
6384 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6386 not_null_expr
, eq_expr
);
6394 /* The following routine generates code for the intrinsic
6395 subroutines from the ISO_C_BINDING module:
6397 * C_F_PROCPOINTER. */
6400 conv_isocbinding_subroutine (gfc_code
*code
)
6407 tree desc
, dim
, tmp
, stride
, offset
;
6408 stmtblock_t body
, block
;
6410 gfc_actual_arglist
*arg
= code
->ext
.actual
;
6412 gfc_init_se (&se
, NULL
);
6413 gfc_init_se (&cptrse
, NULL
);
6414 gfc_conv_expr (&cptrse
, arg
->expr
);
6415 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
6416 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
6418 gfc_init_se (&fptrse
, NULL
);
6419 if (arg
->next
->expr
->rank
== 0)
6421 fptrse
.want_pointer
= 1;
6422 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
6423 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
6424 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
6425 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6426 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
6427 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
6429 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6430 TREE_TYPE (fptrse
.expr
),
6432 fold_convert (TREE_TYPE (fptrse
.expr
),
6434 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
6435 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6436 return gfc_finish_block (&se
.pre
);
6439 gfc_start_block (&block
);
6441 /* Get the descriptor of the Fortran pointer. */
6442 fptrse
.descriptor_only
= 1;
6443 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
6444 gfc_add_block_to_block (&block
, &fptrse
.pre
);
6447 /* Set data value, dtype, and offset. */
6448 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
6449 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
6450 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
6451 gfc_get_dtype (TREE_TYPE (desc
)));
6453 /* Start scalarization of the bounds, using the shape argument. */
6455 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
6456 gcc_assert (shape_ss
!= gfc_ss_terminator
);
6457 gfc_init_se (&shapese
, NULL
);
6459 gfc_init_loopinfo (&loop
);
6460 gfc_add_ss_to_loop (&loop
, shape_ss
);
6461 gfc_conv_ss_startstride (&loop
);
6462 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
6463 gfc_mark_ss_chain_used (shape_ss
, 1);
6465 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
6466 shapese
.ss
= shape_ss
;
6468 stride
= gfc_create_var (gfc_array_index_type
, "stride");
6469 offset
= gfc_create_var (gfc_array_index_type
, "offset");
6470 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
6471 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6474 gfc_start_scalarized_body (&loop
, &body
);
6476 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6477 loop
.loopvar
[0], loop
.from
[0]);
6479 /* Set bounds and stride. */
6480 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
6481 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
6483 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
6484 gfc_add_block_to_block (&body
, &shapese
.pre
);
6485 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
6486 gfc_add_block_to_block (&body
, &shapese
.post
);
6488 /* Calculate offset. */
6489 gfc_add_modify (&body
, offset
,
6490 fold_build2_loc (input_location
, PLUS_EXPR
,
6491 gfc_array_index_type
, offset
, stride
));
6492 /* Update stride. */
6493 gfc_add_modify (&body
, stride
,
6494 fold_build2_loc (input_location
, MULT_EXPR
,
6495 gfc_array_index_type
, stride
,
6496 fold_convert (gfc_array_index_type
,
6498 /* Finish scalarization loop. */
6499 gfc_trans_scalarizing_loops (&loop
, &body
);
6500 gfc_add_block_to_block (&block
, &loop
.pre
);
6501 gfc_add_block_to_block (&block
, &loop
.post
);
6502 gfc_add_block_to_block (&block
, &fptrse
.post
);
6503 gfc_cleanup_loop (&loop
);
6505 gfc_add_modify (&block
, offset
,
6506 fold_build1_loc (input_location
, NEGATE_EXPR
,
6507 gfc_array_index_type
, offset
));
6508 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
6510 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
6511 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6512 return gfc_finish_block (&se
.pre
);
6516 /* Generate code for an intrinsic function. Some map directly to library
6517 calls, others get special handling. In some cases the name of the function
6518 used depends on the type specifiers. */
6521 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6527 name
= &expr
->value
.function
.name
[2];
6531 lib
= gfc_is_intrinsic_libcall (expr
);
6535 se
->ignore_optional
= 1;
6537 switch (expr
->value
.function
.isym
->id
)
6539 case GFC_ISYM_EOSHIFT
:
6541 case GFC_ISYM_RESHAPE
:
6542 /* For all of those the first argument specifies the type and the
6543 third is optional. */
6544 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6548 gfc_conv_intrinsic_funcall (se
, expr
);
6556 switch (expr
->value
.function
.isym
->id
)
6561 case GFC_ISYM_REPEAT
:
6562 gfc_conv_intrinsic_repeat (se
, expr
);
6566 gfc_conv_intrinsic_trim (se
, expr
);
6569 case GFC_ISYM_SC_KIND
:
6570 gfc_conv_intrinsic_sc_kind (se
, expr
);
6573 case GFC_ISYM_SI_KIND
:
6574 gfc_conv_intrinsic_si_kind (se
, expr
);
6577 case GFC_ISYM_SR_KIND
:
6578 gfc_conv_intrinsic_sr_kind (se
, expr
);
6581 case GFC_ISYM_EXPONENT
:
6582 gfc_conv_intrinsic_exponent (se
, expr
);
6586 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6588 fndecl
= gfor_fndecl_string_scan
;
6590 fndecl
= gfor_fndecl_string_scan_char4
;
6594 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6597 case GFC_ISYM_VERIFY
:
6598 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6600 fndecl
= gfor_fndecl_string_verify
;
6602 fndecl
= gfor_fndecl_string_verify_char4
;
6606 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6609 case GFC_ISYM_ALLOCATED
:
6610 gfc_conv_allocated (se
, expr
);
6613 case GFC_ISYM_ASSOCIATED
:
6614 gfc_conv_associated(se
, expr
);
6617 case GFC_ISYM_SAME_TYPE_AS
:
6618 gfc_conv_same_type_as (se
, expr
);
6622 gfc_conv_intrinsic_abs (se
, expr
);
6625 case GFC_ISYM_ADJUSTL
:
6626 if (expr
->ts
.kind
== 1)
6627 fndecl
= gfor_fndecl_adjustl
;
6628 else if (expr
->ts
.kind
== 4)
6629 fndecl
= gfor_fndecl_adjustl_char4
;
6633 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6636 case GFC_ISYM_ADJUSTR
:
6637 if (expr
->ts
.kind
== 1)
6638 fndecl
= gfor_fndecl_adjustr
;
6639 else if (expr
->ts
.kind
== 4)
6640 fndecl
= gfor_fndecl_adjustr_char4
;
6644 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6647 case GFC_ISYM_AIMAG
:
6648 gfc_conv_intrinsic_imagpart (se
, expr
);
6652 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6656 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6659 case GFC_ISYM_ANINT
:
6660 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6664 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6668 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6671 case GFC_ISYM_BTEST
:
6672 gfc_conv_intrinsic_btest (se
, expr
);
6676 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6680 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6684 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6688 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6691 case GFC_ISYM_C_ASSOCIATED
:
6692 case GFC_ISYM_C_FUNLOC
:
6693 case GFC_ISYM_C_LOC
:
6694 conv_isocbinding_function (se
, expr
);
6697 case GFC_ISYM_ACHAR
:
6699 gfc_conv_intrinsic_char (se
, expr
);
6702 case GFC_ISYM_CONVERSION
:
6704 case GFC_ISYM_LOGICAL
:
6706 gfc_conv_intrinsic_conversion (se
, expr
);
6709 /* Integer conversions are handled separately to make sure we get the
6710 correct rounding mode. */
6715 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6719 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6722 case GFC_ISYM_CEILING
:
6723 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6726 case GFC_ISYM_FLOOR
:
6727 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6731 gfc_conv_intrinsic_mod (se
, expr
, 0);
6734 case GFC_ISYM_MODULO
:
6735 gfc_conv_intrinsic_mod (se
, expr
, 1);
6738 case GFC_ISYM_CMPLX
:
6739 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6742 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6743 gfc_conv_intrinsic_iargc (se
, expr
);
6746 case GFC_ISYM_COMPLEX
:
6747 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6750 case GFC_ISYM_CONJG
:
6751 gfc_conv_intrinsic_conjg (se
, expr
);
6754 case GFC_ISYM_COUNT
:
6755 gfc_conv_intrinsic_count (se
, expr
);
6758 case GFC_ISYM_CTIME
:
6759 gfc_conv_intrinsic_ctime (se
, expr
);
6763 gfc_conv_intrinsic_dim (se
, expr
);
6766 case GFC_ISYM_DOT_PRODUCT
:
6767 gfc_conv_intrinsic_dot_product (se
, expr
);
6770 case GFC_ISYM_DPROD
:
6771 gfc_conv_intrinsic_dprod (se
, expr
);
6774 case GFC_ISYM_DSHIFTL
:
6775 gfc_conv_intrinsic_dshift (se
, expr
, true);
6778 case GFC_ISYM_DSHIFTR
:
6779 gfc_conv_intrinsic_dshift (se
, expr
, false);
6782 case GFC_ISYM_FDATE
:
6783 gfc_conv_intrinsic_fdate (se
, expr
);
6786 case GFC_ISYM_FRACTION
:
6787 gfc_conv_intrinsic_fraction (se
, expr
);
6791 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6795 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6799 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6802 case GFC_ISYM_IBCLR
:
6803 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6806 case GFC_ISYM_IBITS
:
6807 gfc_conv_intrinsic_ibits (se
, expr
);
6810 case GFC_ISYM_IBSET
:
6811 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6814 case GFC_ISYM_IACHAR
:
6815 case GFC_ISYM_ICHAR
:
6816 /* We assume ASCII character sequence. */
6817 gfc_conv_intrinsic_ichar (se
, expr
);
6820 case GFC_ISYM_IARGC
:
6821 gfc_conv_intrinsic_iargc (se
, expr
);
6825 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6828 case GFC_ISYM_INDEX
:
6829 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6831 fndecl
= gfor_fndecl_string_index
;
6833 fndecl
= gfor_fndecl_string_index_char4
;
6837 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6841 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6844 case GFC_ISYM_IPARITY
:
6845 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6848 case GFC_ISYM_IS_IOSTAT_END
:
6849 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6852 case GFC_ISYM_IS_IOSTAT_EOR
:
6853 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6856 case GFC_ISYM_ISNAN
:
6857 gfc_conv_intrinsic_isnan (se
, expr
);
6860 case GFC_ISYM_LSHIFT
:
6861 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6864 case GFC_ISYM_RSHIFT
:
6865 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6868 case GFC_ISYM_SHIFTA
:
6869 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6872 case GFC_ISYM_SHIFTL
:
6873 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6876 case GFC_ISYM_SHIFTR
:
6877 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6880 case GFC_ISYM_ISHFT
:
6881 gfc_conv_intrinsic_ishft (se
, expr
);
6884 case GFC_ISYM_ISHFTC
:
6885 gfc_conv_intrinsic_ishftc (se
, expr
);
6888 case GFC_ISYM_LEADZ
:
6889 gfc_conv_intrinsic_leadz (se
, expr
);
6892 case GFC_ISYM_TRAILZ
:
6893 gfc_conv_intrinsic_trailz (se
, expr
);
6896 case GFC_ISYM_POPCNT
:
6897 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6900 case GFC_ISYM_POPPAR
:
6901 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6904 case GFC_ISYM_LBOUND
:
6905 gfc_conv_intrinsic_bound (se
, expr
, 0);
6908 case GFC_ISYM_LCOBOUND
:
6909 conv_intrinsic_cobound (se
, expr
);
6912 case GFC_ISYM_TRANSPOSE
:
6913 /* The scalarizer has already been set up for reversed dimension access
6914 order ; now we just get the argument value normally. */
6915 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6919 gfc_conv_intrinsic_len (se
, expr
);
6922 case GFC_ISYM_LEN_TRIM
:
6923 gfc_conv_intrinsic_len_trim (se
, expr
);
6927 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6931 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6935 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6939 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6942 case GFC_ISYM_MASKL
:
6943 gfc_conv_intrinsic_mask (se
, expr
, 1);
6946 case GFC_ISYM_MASKR
:
6947 gfc_conv_intrinsic_mask (se
, expr
, 0);
6951 if (expr
->ts
.type
== BT_CHARACTER
)
6952 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6954 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6957 case GFC_ISYM_MAXLOC
:
6958 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6961 case GFC_ISYM_MAXVAL
:
6962 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6965 case GFC_ISYM_MERGE
:
6966 gfc_conv_intrinsic_merge (se
, expr
);
6969 case GFC_ISYM_MERGE_BITS
:
6970 gfc_conv_intrinsic_merge_bits (se
, expr
);
6974 if (expr
->ts
.type
== BT_CHARACTER
)
6975 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6977 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6980 case GFC_ISYM_MINLOC
:
6981 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6984 case GFC_ISYM_MINVAL
:
6985 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6988 case GFC_ISYM_NEAREST
:
6989 gfc_conv_intrinsic_nearest (se
, expr
);
6992 case GFC_ISYM_NORM2
:
6993 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6997 gfc_conv_intrinsic_not (se
, expr
);
7001 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7004 case GFC_ISYM_PARITY
:
7005 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
7008 case GFC_ISYM_PRESENT
:
7009 gfc_conv_intrinsic_present (se
, expr
);
7012 case GFC_ISYM_PRODUCT
:
7013 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
7017 gfc_conv_intrinsic_rank (se
, expr
);
7020 case GFC_ISYM_RRSPACING
:
7021 gfc_conv_intrinsic_rrspacing (se
, expr
);
7024 case GFC_ISYM_SET_EXPONENT
:
7025 gfc_conv_intrinsic_set_exponent (se
, expr
);
7028 case GFC_ISYM_SCALE
:
7029 gfc_conv_intrinsic_scale (se
, expr
);
7033 gfc_conv_intrinsic_sign (se
, expr
);
7037 gfc_conv_intrinsic_size (se
, expr
);
7040 case GFC_ISYM_SIZEOF
:
7041 case GFC_ISYM_C_SIZEOF
:
7042 gfc_conv_intrinsic_sizeof (se
, expr
);
7045 case GFC_ISYM_STORAGE_SIZE
:
7046 gfc_conv_intrinsic_storage_size (se
, expr
);
7049 case GFC_ISYM_SPACING
:
7050 gfc_conv_intrinsic_spacing (se
, expr
);
7053 case GFC_ISYM_STRIDE
:
7054 conv_intrinsic_stride (se
, expr
);
7058 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
7061 case GFC_ISYM_TRANSFER
:
7062 if (se
->ss
&& se
->ss
->info
->useflags
)
7063 /* Access the previously obtained result. */
7064 gfc_conv_tmp_array_ref (se
);
7066 gfc_conv_intrinsic_transfer (se
, expr
);
7069 case GFC_ISYM_TTYNAM
:
7070 gfc_conv_intrinsic_ttynam (se
, expr
);
7073 case GFC_ISYM_UBOUND
:
7074 gfc_conv_intrinsic_bound (se
, expr
, 1);
7077 case GFC_ISYM_UCOBOUND
:
7078 conv_intrinsic_cobound (se
, expr
);
7082 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7086 gfc_conv_intrinsic_loc (se
, expr
);
7089 case GFC_ISYM_THIS_IMAGE
:
7090 /* For num_images() == 1, handle as LCOBOUND. */
7091 if (expr
->value
.function
.actual
->expr
7092 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7093 conv_intrinsic_cobound (se
, expr
);
7095 trans_this_image (se
, expr
);
7098 case GFC_ISYM_IMAGE_INDEX
:
7099 trans_image_index (se
, expr
);
7102 case GFC_ISYM_NUM_IMAGES
:
7103 trans_num_images (se
);
7106 case GFC_ISYM_ACCESS
:
7107 case GFC_ISYM_CHDIR
:
7108 case GFC_ISYM_CHMOD
:
7109 case GFC_ISYM_DTIME
:
7110 case GFC_ISYM_ETIME
:
7111 case GFC_ISYM_EXTENDS_TYPE_OF
:
7113 case GFC_ISYM_FGETC
:
7116 case GFC_ISYM_FPUTC
:
7117 case GFC_ISYM_FSTAT
:
7118 case GFC_ISYM_FTELL
:
7119 case GFC_ISYM_GETCWD
:
7120 case GFC_ISYM_GETGID
:
7121 case GFC_ISYM_GETPID
:
7122 case GFC_ISYM_GETUID
:
7123 case GFC_ISYM_HOSTNM
:
7125 case GFC_ISYM_IERRNO
:
7126 case GFC_ISYM_IRAND
:
7127 case GFC_ISYM_ISATTY
:
7130 case GFC_ISYM_LSTAT
:
7131 case GFC_ISYM_MALLOC
:
7132 case GFC_ISYM_MATMUL
:
7133 case GFC_ISYM_MCLOCK
:
7134 case GFC_ISYM_MCLOCK8
:
7136 case GFC_ISYM_RENAME
:
7137 case GFC_ISYM_SECOND
:
7138 case GFC_ISYM_SECNDS
:
7139 case GFC_ISYM_SIGNAL
:
7141 case GFC_ISYM_SYMLNK
:
7142 case GFC_ISYM_SYSTEM
:
7144 case GFC_ISYM_TIME8
:
7145 case GFC_ISYM_UMASK
:
7146 case GFC_ISYM_UNLINK
:
7148 gfc_conv_intrinsic_funcall (se
, expr
);
7151 case GFC_ISYM_EOSHIFT
:
7153 case GFC_ISYM_RESHAPE
:
7154 /* For those, expr->rank should always be >0 and thus the if above the
7155 switch should have matched. */
7160 gfc_conv_intrinsic_lib_function (se
, expr
);
7167 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
7169 gfc_ss
*arg_ss
, *tmp_ss
;
7170 gfc_actual_arglist
*arg
;
7172 arg
= expr
->value
.function
.actual
;
7174 gcc_assert (arg
->expr
);
7176 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
7177 gcc_assert (arg_ss
!= gfc_ss_terminator
);
7179 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
7181 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
7182 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
7186 gcc_assert (tmp_ss
->dimen
== 2);
7188 /* We just invert dimensions. */
7189 tmp_dim
= tmp_ss
->dim
[0];
7190 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
7191 tmp_ss
->dim
[1] = tmp_dim
;
7194 /* Stop when tmp_ss points to the last valid element of the chain... */
7195 if (tmp_ss
->next
== gfc_ss_terminator
)
7199 /* ... so that we can attach the rest of the chain to it. */
7206 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
7207 This has the side effect of reversing the nested list, so there is no
7208 need to call gfc_reverse_ss on it (the given list is assumed not to be
7212 nest_loop_dimension (gfc_ss
*ss
, int dim
)
7215 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
7216 gfc_loopinfo
*new_loop
;
7218 gcc_assert (ss
!= gfc_ss_terminator
);
7220 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
7222 new_ss
= gfc_get_ss ();
7223 new_ss
->next
= prev_ss
;
7224 new_ss
->parent
= ss
;
7225 new_ss
->info
= ss
->info
;
7226 new_ss
->info
->refcount
++;
7229 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
7230 && ss
->info
->type
!= GFC_SS_REFERENCE
);
7233 new_ss
->dim
[0] = ss
->dim
[dim
];
7235 gcc_assert (dim
< ss
->dimen
);
7237 ss_dim
= --ss
->dimen
;
7238 for (i
= dim
; i
< ss_dim
; i
++)
7239 ss
->dim
[i
] = ss
->dim
[i
+ 1];
7241 ss
->dim
[ss_dim
] = 0;
7247 ss
->nested_ss
->parent
= new_ss
;
7248 new_ss
->nested_ss
= ss
->nested_ss
;
7250 ss
->nested_ss
= new_ss
;
7253 new_loop
= gfc_get_loopinfo ();
7254 gfc_init_loopinfo (new_loop
);
7256 gcc_assert (prev_ss
!= NULL
);
7257 gcc_assert (prev_ss
!= gfc_ss_terminator
);
7258 gfc_add_ss_to_loop (new_loop
, prev_ss
);
7259 return new_ss
->parent
;
7263 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
7264 is to be inlined. */
7267 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
7269 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
7270 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
7272 bool scalar_mask
= false;
7274 /* The rank of the result will be determined later. */
7275 arg1
= expr
->value
.function
.actual
;
7278 gcc_assert (arg3
!= NULL
);
7280 if (expr
->rank
== 0)
7283 tmp_ss
= gfc_ss_terminator
;
7289 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
7290 if (mask_ss
== tmp_ss
)
7296 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
7297 gcc_assert (array_ss
!= tmp_ss
);
7299 /* Odd thing: If the mask is scalar, it is used by the frontend after
7300 the array (to make an if around the nested loop). Thus it shall
7301 be after array_ss once the gfc_ss list is reversed. */
7303 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
7307 /* "Hide" the dimension on which we will sum in the first arg's scalarization
7309 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
7310 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
7318 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
7321 switch (expr
->value
.function
.isym
->id
)
7323 case GFC_ISYM_PRODUCT
:
7325 return walk_inline_intrinsic_arith (ss
, expr
);
7327 case GFC_ISYM_TRANSPOSE
:
7328 return walk_inline_intrinsic_transpose (ss
, expr
);
7337 /* This generates code to execute before entering the scalarization loop.
7338 Currently does nothing. */
7341 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7343 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7345 case GFC_ISYM_UBOUND
:
7346 case GFC_ISYM_LBOUND
:
7347 case GFC_ISYM_UCOBOUND
:
7348 case GFC_ISYM_LCOBOUND
:
7349 case GFC_ISYM_THIS_IMAGE
:
7358 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7359 are expanded into code inside the scalarization loop. */
7362 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7364 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7365 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7367 /* The two argument version returns a scalar. */
7368 if (expr
->value
.function
.actual
->next
->expr
)
7371 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7375 /* Walk an intrinsic array libcall. */
7378 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7380 gcc_assert (expr
->rank
> 0);
7381 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7385 /* Return whether the function call expression EXPR will be expanded
7386 inline by gfc_conv_intrinsic_function. */
7389 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7391 gfc_actual_arglist
*args
;
7393 if (!expr
->value
.function
.isym
)
7396 switch (expr
->value
.function
.isym
->id
)
7398 case GFC_ISYM_PRODUCT
:
7400 /* Disable inline expansion if code size matters. */
7404 args
= expr
->value
.function
.actual
;
7405 /* We need to be able to subset the SUM argument at compile-time. */
7406 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7411 case GFC_ISYM_TRANSPOSE
:
7420 /* Returns nonzero if the specified intrinsic function call maps directly to
7421 an external library call. Should only be used for functions that return
7425 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7427 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7428 gcc_assert (expr
->rank
> 0);
7430 if (gfc_inline_intrinsic_function_p (expr
))
7433 switch (expr
->value
.function
.isym
->id
)
7437 case GFC_ISYM_COUNT
:
7441 case GFC_ISYM_IPARITY
:
7442 case GFC_ISYM_MATMUL
:
7443 case GFC_ISYM_MAXLOC
:
7444 case GFC_ISYM_MAXVAL
:
7445 case GFC_ISYM_MINLOC
:
7446 case GFC_ISYM_MINVAL
:
7447 case GFC_ISYM_NORM2
:
7448 case GFC_ISYM_PARITY
:
7449 case GFC_ISYM_PRODUCT
:
7451 case GFC_ISYM_SHAPE
:
7452 case GFC_ISYM_SPREAD
:
7454 /* Ignore absent optional parameters. */
7457 case GFC_ISYM_RESHAPE
:
7458 case GFC_ISYM_CSHIFT
:
7459 case GFC_ISYM_EOSHIFT
:
7461 case GFC_ISYM_UNPACK
:
7462 /* Pass absent optional parameters. */
7470 /* Walk an intrinsic function. */
7472 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7473 gfc_intrinsic_sym
* isym
)
7477 if (isym
->elemental
)
7478 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7479 NULL
, GFC_SS_SCALAR
);
7481 if (expr
->rank
== 0)
7484 if (gfc_inline_intrinsic_function_p (expr
))
7485 return walk_inline_intrinsic_function (ss
, expr
);
7487 if (gfc_is_intrinsic_libcall (expr
))
7488 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7490 /* Special cases. */
7493 case GFC_ISYM_LBOUND
:
7494 case GFC_ISYM_LCOBOUND
:
7495 case GFC_ISYM_UBOUND
:
7496 case GFC_ISYM_UCOBOUND
:
7497 case GFC_ISYM_THIS_IMAGE
:
7498 return gfc_walk_intrinsic_bound (ss
, expr
);
7500 case GFC_ISYM_TRANSFER
:
7501 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7504 /* This probably meant someone forgot to add an intrinsic to the above
7505 list(s) when they implemented it, or something's gone horribly
7513 conv_intrinsic_atomic_def (gfc_code
*code
)
7518 gfc_init_se (&atom
, NULL
);
7519 gfc_init_se (&value
, NULL
);
7520 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7521 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7523 gfc_init_block (&block
);
7524 gfc_add_modify (&block
, atom
.expr
,
7525 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7526 return gfc_finish_block (&block
);
7531 conv_intrinsic_atomic_ref (gfc_code
*code
)
7536 gfc_init_se (&atom
, NULL
);
7537 gfc_init_se (&value
, NULL
);
7538 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7539 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7541 gfc_init_block (&block
);
7542 gfc_add_modify (&block
, value
.expr
,
7543 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7544 return gfc_finish_block (&block
);
7549 conv_intrinsic_move_alloc (gfc_code
*code
)
7552 gfc_expr
*from_expr
, *to_expr
;
7553 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7554 gfc_se from_se
, to_se
;
7558 gfc_start_block (&block
);
7560 from_expr
= code
->ext
.actual
->expr
;
7561 to_expr
= code
->ext
.actual
->next
->expr
;
7563 gfc_init_se (&from_se
, NULL
);
7564 gfc_init_se (&to_se
, NULL
);
7566 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7567 || to_expr
->ts
.type
== BT_CLASS
);
7568 coarray
= gfc_get_corank (from_expr
) != 0;
7570 if (from_expr
->rank
== 0 && !coarray
)
7572 if (from_expr
->ts
.type
!= BT_CLASS
)
7573 from_expr2
= from_expr
;
7576 from_expr2
= gfc_copy_expr (from_expr
);
7577 gfc_add_data_component (from_expr2
);
7580 if (to_expr
->ts
.type
!= BT_CLASS
)
7584 to_expr2
= gfc_copy_expr (to_expr
);
7585 gfc_add_data_component (to_expr2
);
7588 from_se
.want_pointer
= 1;
7589 to_se
.want_pointer
= 1;
7590 gfc_conv_expr (&from_se
, from_expr2
);
7591 gfc_conv_expr (&to_se
, to_expr2
);
7592 gfc_add_block_to_block (&block
, &from_se
.pre
);
7593 gfc_add_block_to_block (&block
, &to_se
.pre
);
7595 /* Deallocate "to". */
7596 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7597 to_expr
, to_expr
->ts
);
7598 gfc_add_expr_to_block (&block
, tmp
);
7600 /* Assign (_data) pointers. */
7601 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7602 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7604 /* Set "from" to NULL. */
7605 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7606 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7608 gfc_add_block_to_block (&block
, &from_se
.post
);
7609 gfc_add_block_to_block (&block
, &to_se
.post
);
7612 if (to_expr
->ts
.type
== BT_CLASS
)
7616 gfc_free_expr (to_expr2
);
7617 gfc_init_se (&to_se
, NULL
);
7618 to_se
.want_pointer
= 1;
7619 gfc_add_vptr_component (to_expr
);
7620 gfc_conv_expr (&to_se
, to_expr
);
7622 if (from_expr
->ts
.type
== BT_CLASS
)
7624 if (UNLIMITED_POLY (from_expr
))
7628 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7632 gfc_free_expr (from_expr2
);
7633 gfc_init_se (&from_se
, NULL
);
7634 from_se
.want_pointer
= 1;
7635 gfc_add_vptr_component (from_expr
);
7636 gfc_conv_expr (&from_se
, from_expr
);
7637 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7638 fold_convert (TREE_TYPE (to_se
.expr
),
7641 /* Reset _vptr component to declared type. */
7642 if (UNLIMITED_POLY (from_expr
))
7643 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7644 fold_convert (TREE_TYPE (from_se
.expr
),
7645 null_pointer_node
));
7648 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7649 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7650 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7655 if (from_expr
->ts
.type
!= BT_DERIVED
)
7656 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7658 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7660 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7661 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7662 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7666 return gfc_finish_block (&block
);
7669 /* Update _vptr component. */
7670 if (to_expr
->ts
.type
== BT_CLASS
)
7674 to_se
.want_pointer
= 1;
7675 to_expr2
= gfc_copy_expr (to_expr
);
7676 gfc_add_vptr_component (to_expr2
);
7677 gfc_conv_expr (&to_se
, to_expr2
);
7679 if (from_expr
->ts
.type
== BT_CLASS
)
7681 if (UNLIMITED_POLY (from_expr
))
7685 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7689 from_se
.want_pointer
= 1;
7690 from_expr2
= gfc_copy_expr (from_expr
);
7691 gfc_add_vptr_component (from_expr2
);
7692 gfc_conv_expr (&from_se
, from_expr2
);
7693 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7694 fold_convert (TREE_TYPE (to_se
.expr
),
7697 /* Reset _vptr component to declared type. */
7698 if (UNLIMITED_POLY (from_expr
))
7699 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7700 fold_convert (TREE_TYPE (from_se
.expr
),
7701 null_pointer_node
));
7704 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7705 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7706 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7711 if (from_expr
->ts
.type
!= BT_DERIVED
)
7712 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7714 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7716 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7717 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7718 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7721 gfc_free_expr (to_expr2
);
7722 gfc_init_se (&to_se
, NULL
);
7724 if (from_expr
->ts
.type
== BT_CLASS
)
7726 gfc_free_expr (from_expr2
);
7727 gfc_init_se (&from_se
, NULL
);
7732 /* Deallocate "to". */
7733 if (from_expr
->rank
== 0)
7735 to_se
.want_coarray
= 1;
7736 from_se
.want_coarray
= 1;
7738 gfc_conv_expr_descriptor (&to_se
, to_expr
);
7739 gfc_conv_expr_descriptor (&from_se
, from_expr
);
7741 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
7742 is an image control "statement", cf. IR F08/0040 in 12-006A. */
7743 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
7747 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
7748 NULL_TREE
, NULL_TREE
, true, to_expr
,
7750 gfc_add_expr_to_block (&block
, tmp
);
7752 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7753 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7754 boolean_type_node
, tmp
,
7755 fold_convert (TREE_TYPE (tmp
),
7756 null_pointer_node
));
7757 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7758 3, null_pointer_node
, null_pointer_node
,
7759 build_int_cst (integer_type_node
, 0));
7761 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
7762 tmp
, build_empty_stmt (input_location
));
7763 gfc_add_expr_to_block (&block
, tmp
);
7767 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7768 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
7769 NULL_TREE
, true, to_expr
, false);
7770 gfc_add_expr_to_block (&block
, tmp
);
7773 /* Move the pointer and update the array descriptor data. */
7774 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7776 /* Set "from" to NULL. */
7777 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7778 gfc_add_modify_loc (input_location
, &block
, tmp
,
7779 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7781 return gfc_finish_block (&block
);
7786 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7790 gcc_assert (code
->resolved_isym
);
7792 switch (code
->resolved_isym
->id
)
7794 case GFC_ISYM_MOVE_ALLOC
:
7795 res
= conv_intrinsic_move_alloc (code
);
7798 case GFC_ISYM_ATOMIC_DEF
:
7799 res
= conv_intrinsic_atomic_def (code
);
7802 case GFC_ISYM_ATOMIC_REF
:
7803 res
= conv_intrinsic_atomic_ref (code
);
7806 case GFC_ISYM_C_F_POINTER
:
7807 case GFC_ISYM_C_F_PROCPOINTER
:
7808 res
= conv_isocbinding_subroutine (code
);
7820 #include "gt-fortran-trans-intrinsic.h"