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. */
29 #include "stringpool.h"
30 #include "tree-nested.h"
31 #include "stor-layout.h"
33 #include "diagnostic-core.h" /* For internal_error. */
34 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "intrinsic.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
45 #include "tree-nested.h"
47 /* This maps Fortran intrinsic math functions to external library or GCC
49 typedef struct GTY(()) gfc_intrinsic_map_t
{
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function float_built_in
;
57 enum built_in_function double_built_in
;
58 enum built_in_function long_double_built_in
;
59 enum built_in_function complex_float_built_in
;
60 enum built_in_function complex_double_built_in
;
61 enum built_in_function complex_long_double_built_in
;
63 /* True if the naming pattern is to prepend "c" for complex and
64 append "f" for kind=4. False if the naming pattern is to
65 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
68 /* True if a complex version of the function exists. */
69 bool complex_available
;
71 /* True if the function should be marked const. */
74 /* The base library name of this function. */
77 /* Cache decls created for the various operand types. */
89 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
90 defines complex variants of all of the entries in mathbuiltins.def
92 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
93 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
94 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
95 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
96 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
98 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
99 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
100 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
101 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
102 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
104 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
105 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
106 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
108 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
110 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
111 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
112 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
113 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
114 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
116 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
118 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
119 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
120 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
121 #include "mathbuiltins.def"
123 /* Functions in libgfortran. */
124 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
127 LIB_FUNCTION (NONE
, NULL
, false)
132 #undef DEFINE_MATH_BUILTIN
133 #undef DEFINE_MATH_BUILTIN_C
136 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
139 /* Find the correct variant of a given builtin from its argument. */
141 builtin_decl_for_precision (enum built_in_function base_built_in
,
144 enum built_in_function i
= END_BUILTINS
;
146 gfc_intrinsic_map_t
*m
;
147 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
150 if (precision
== TYPE_PRECISION (float_type_node
))
151 i
= m
->float_built_in
;
152 else if (precision
== TYPE_PRECISION (double_type_node
))
153 i
= m
->double_built_in
;
154 else if (precision
== TYPE_PRECISION (long_double_type_node
))
155 i
= m
->long_double_built_in
;
156 else if (precision
== TYPE_PRECISION (float128_type_node
))
158 /* Special treatment, because it is not exactly a built-in, but
159 a library function. */
160 return m
->real16_decl
;
163 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
168 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
171 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
173 if (gfc_real_kinds
[i
].c_float128
)
175 /* For __float128, the story is a bit different, because we return
176 a decl to a library function rather than a built-in. */
177 gfc_intrinsic_map_t
*m
;
178 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
181 return m
->real16_decl
;
184 return builtin_decl_for_precision (double_built_in
,
185 gfc_real_kinds
[i
].mode_precision
);
189 /* Evaluate the arguments to an intrinsic function. The value
190 of NARGS may be less than the actual number of arguments in EXPR
191 to allow optional "KIND" arguments that are not included in the
192 generated code to be ignored. */
195 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
196 tree
*argarray
, int nargs
)
198 gfc_actual_arglist
*actual
;
200 gfc_intrinsic_arg
*formal
;
204 formal
= expr
->value
.function
.isym
->formal
;
205 actual
= expr
->value
.function
.actual
;
207 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
208 actual
= actual
->next
,
209 formal
= formal
? formal
->next
: NULL
)
213 /* Skip omitted optional arguments. */
220 /* Evaluate the parameter. This will substitute scalarized
221 references automatically. */
222 gfc_init_se (&argse
, se
);
224 if (e
->ts
.type
== BT_CHARACTER
)
226 gfc_conv_expr (&argse
, e
);
227 gfc_conv_string_parameter (&argse
);
228 argarray
[curr_arg
++] = argse
.string_length
;
229 gcc_assert (curr_arg
< nargs
);
232 gfc_conv_expr_val (&argse
, e
);
234 /* If an optional argument is itself an optional dummy argument,
235 check its presence and substitute a null if absent. */
236 if (e
->expr_type
== EXPR_VARIABLE
237 && e
->symtree
->n
.sym
->attr
.optional
240 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
242 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
243 gfc_add_block_to_block (&se
->post
, &argse
.post
);
244 argarray
[curr_arg
] = argse
.expr
;
248 /* Count the number of actual arguments to the intrinsic function EXPR
249 including any "hidden" string length arguments. */
252 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
255 gfc_actual_arglist
*actual
;
257 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
262 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
272 /* Conversions between different types are output by the frontend as
273 intrinsic functions. We implement these directly with inline code. */
276 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
282 nargs
= gfc_intrinsic_argument_list_length (expr
);
283 args
= XALLOCAVEC (tree
, nargs
);
285 /* Evaluate all the arguments passed. Whilst we're only interested in the
286 first one here, there are other parts of the front-end that assume this
287 and will trigger an ICE if it's not the case. */
288 type
= gfc_typenode_for_spec (&expr
->ts
);
289 gcc_assert (expr
->value
.function
.actual
->expr
);
290 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
292 /* Conversion between character kinds involves a call to a library
294 if (expr
->ts
.type
== BT_CHARACTER
)
296 tree fndecl
, var
, addr
, tmp
;
298 if (expr
->ts
.kind
== 1
299 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
300 fndecl
= gfor_fndecl_convert_char4_to_char1
;
301 else if (expr
->ts
.kind
== 4
302 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
303 fndecl
= gfor_fndecl_convert_char1_to_char4
;
307 /* Create the variable storing the converted value. */
308 type
= gfc_get_pchar_type (expr
->ts
.kind
);
309 var
= gfc_create_var (type
, "str");
310 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
312 /* Call the library function that will perform the conversion. */
313 gcc_assert (nargs
>= 2);
314 tmp
= build_call_expr_loc (input_location
,
315 fndecl
, 3, addr
, args
[0], args
[1]);
316 gfc_add_expr_to_block (&se
->pre
, tmp
);
318 /* Free the temporary afterwards. */
319 tmp
= gfc_call_free (var
);
320 gfc_add_expr_to_block (&se
->post
, tmp
);
323 se
->string_length
= args
[0];
328 /* Conversion from complex to non-complex involves taking the real
329 component of the value. */
330 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
331 && expr
->ts
.type
!= BT_COMPLEX
)
335 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
336 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
340 se
->expr
= convert (type
, args
[0]);
343 /* This is needed because the gcc backend only implements
344 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
345 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
346 Similarly for CEILING. */
349 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
356 argtype
= TREE_TYPE (arg
);
357 arg
= gfc_evaluate_now (arg
, pblock
);
359 intval
= convert (type
, arg
);
360 intval
= gfc_evaluate_now (intval
, pblock
);
362 tmp
= convert (argtype
, intval
);
363 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
364 boolean_type_node
, tmp
, arg
);
366 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
367 intval
, build_int_cst (type
, 1));
368 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
373 /* Round to nearest integer, away from zero. */
376 build_round_expr (tree arg
, tree restype
)
380 int argprec
, resprec
;
382 argtype
= TREE_TYPE (arg
);
383 argprec
= TYPE_PRECISION (argtype
);
384 resprec
= TYPE_PRECISION (restype
);
386 /* Depending on the type of the result, choose the int intrinsic
387 (iround, available only as a builtin, therefore cannot use it for
388 __float128), long int intrinsic (lround family) or long long
389 intrinsic (llround). We might also need to convert the result
391 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
393 else if (resprec
<= LONG_TYPE_SIZE
)
394 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
395 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
396 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
400 return fold_convert (restype
, build_call_expr_loc (input_location
,
405 /* Convert a real to an integer using a specific rounding mode.
406 Ideally we would just build the corresponding GENERIC node,
407 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
410 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
411 enum rounding_mode op
)
416 return build_fixbound_expr (pblock
, arg
, type
, 0);
420 return build_fixbound_expr (pblock
, arg
, type
, 1);
424 return build_round_expr (arg
, type
);
428 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
437 /* Round a real value using the specified rounding mode.
438 We use a temporary integer of that same kind size as the result.
439 Values larger than those that can be represented by this kind are
440 unchanged, as they will not be accurate enough to represent the
442 huge = HUGE (KIND (a))
443 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
447 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
459 kind
= expr
->ts
.kind
;
460 nargs
= gfc_intrinsic_argument_list_length (expr
);
463 /* We have builtin functions for some cases. */
467 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
471 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
478 /* Evaluate the argument. */
479 gcc_assert (expr
->value
.function
.actual
->expr
);
480 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
482 /* Use a builtin function if one exists. */
483 if (decl
!= NULL_TREE
)
485 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
489 /* This code is probably redundant, but we'll keep it lying around just
491 type
= gfc_typenode_for_spec (&expr
->ts
);
492 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
494 /* Test if the value is too large to handle sensibly. */
495 gfc_set_model_kind (kind
);
497 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
498 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
499 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
500 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
503 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
504 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
505 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
507 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
509 itype
= gfc_get_int_type (kind
);
511 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
512 tmp
= convert (type
, tmp
);
513 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
519 /* Convert to an integer using the specified rounding mode. */
522 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
528 nargs
= gfc_intrinsic_argument_list_length (expr
);
529 args
= XALLOCAVEC (tree
, nargs
);
531 /* Evaluate the argument, we process all arguments even though we only
532 use the first one for code generation purposes. */
533 type
= gfc_typenode_for_spec (&expr
->ts
);
534 gcc_assert (expr
->value
.function
.actual
->expr
);
535 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
537 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
539 /* Conversion to a different integer kind. */
540 se
->expr
= convert (type
, args
[0]);
544 /* Conversion from complex to non-complex involves taking the real
545 component of the value. */
546 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
547 && expr
->ts
.type
!= BT_COMPLEX
)
551 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
552 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
556 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
561 /* Get the imaginary component of a value. */
564 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
568 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
569 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
570 TREE_TYPE (TREE_TYPE (arg
)), arg
);
574 /* Get the complex conjugate of a value. */
577 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
581 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
582 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
588 define_quad_builtin (const char *name
, tree type
, bool is_const
)
591 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
594 /* Mark the decl as external. */
595 DECL_EXTERNAL (fndecl
) = 1;
596 TREE_PUBLIC (fndecl
) = 1;
598 /* Mark it __attribute__((const)). */
599 TREE_READONLY (fndecl
) = is_const
;
601 rest_of_decl_compilation (fndecl
, 1, 0);
608 /* Initialize function decls for library functions. The external functions
609 are created as required. Builtin functions are added here. */
612 gfc_build_intrinsic_lib_fndecls (void)
614 gfc_intrinsic_map_t
*m
;
615 tree quad_decls
[END_BUILTINS
+ 1];
617 if (gfc_real16_is_float128
)
619 /* If we have soft-float types, we create the decls for their
620 C99-like library functions. For now, we only handle __float128
621 q-suffixed functions. */
623 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
624 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
626 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
628 type
= float128_type_node
;
629 complex_type
= complex_float128_type_node
;
630 /* type (*) (type) */
631 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
633 func_iround
= build_function_type_list (integer_type_node
,
635 /* long (*) (type) */
636 func_lround
= build_function_type_list (long_integer_type_node
,
638 /* long long (*) (type) */
639 func_llround
= build_function_type_list (long_long_integer_type_node
,
641 /* type (*) (type, type) */
642 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
643 /* type (*) (type, &int) */
645 = build_function_type_list (type
,
647 build_pointer_type (integer_type_node
),
649 /* type (*) (type, int) */
650 func_scalbn
= build_function_type_list (type
,
651 type
, integer_type_node
, NULL_TREE
);
652 /* type (*) (complex type) */
653 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
654 /* complex type (*) (complex type, complex type) */
656 = build_function_type_list (complex_type
,
657 complex_type
, complex_type
, NULL_TREE
);
659 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
660 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
661 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
663 /* Only these built-ins are actually needed here. These are used directly
664 from the code, when calling builtin_decl_for_precision() or
665 builtin_decl_for_float_type(). The others are all constructed by
666 gfc_get_intrinsic_lib_fndecl(). */
667 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
668 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
670 #include "mathbuiltins.def"
674 #undef DEFINE_MATH_BUILTIN
675 #undef DEFINE_MATH_BUILTIN_C
679 /* Add GCC builtin functions. */
680 for (m
= gfc_intrinsic_map
;
681 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
683 if (m
->float_built_in
!= END_BUILTINS
)
684 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
685 if (m
->complex_float_built_in
!= END_BUILTINS
)
686 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
687 if (m
->double_built_in
!= END_BUILTINS
)
688 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
689 if (m
->complex_double_built_in
!= END_BUILTINS
)
690 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
692 /* If real(kind=10) exists, it is always long double. */
693 if (m
->long_double_built_in
!= END_BUILTINS
)
694 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
695 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
697 = builtin_decl_explicit (m
->complex_long_double_built_in
);
699 if (!gfc_real16_is_float128
)
701 if (m
->long_double_built_in
!= END_BUILTINS
)
702 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
703 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
705 = builtin_decl_explicit (m
->complex_long_double_built_in
);
707 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
709 /* Quad-precision function calls are constructed when first
710 needed by builtin_decl_for_precision(), except for those
711 that will be used directly (define by OTHER_BUILTIN). */
712 m
->real16_decl
= quad_decls
[m
->double_built_in
];
714 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
716 /* Same thing for the complex ones. */
717 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
723 /* Create a fndecl for a simple intrinsic library function. */
726 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
729 vec
<tree
, va_gc
> *argtypes
;
731 gfc_actual_arglist
*actual
;
734 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
737 if (ts
->type
== BT_REAL
)
742 pdecl
= &m
->real4_decl
;
745 pdecl
= &m
->real8_decl
;
748 pdecl
= &m
->real10_decl
;
751 pdecl
= &m
->real16_decl
;
757 else if (ts
->type
== BT_COMPLEX
)
759 gcc_assert (m
->complex_available
);
764 pdecl
= &m
->complex4_decl
;
767 pdecl
= &m
->complex8_decl
;
770 pdecl
= &m
->complex10_decl
;
773 pdecl
= &m
->complex16_decl
;
787 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
788 if (gfc_real_kinds
[n
].c_float
)
789 snprintf (name
, sizeof (name
), "%s%s%s",
790 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
791 else if (gfc_real_kinds
[n
].c_double
)
792 snprintf (name
, sizeof (name
), "%s%s",
793 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
794 else if (gfc_real_kinds
[n
].c_long_double
)
795 snprintf (name
, sizeof (name
), "%s%s%s",
796 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
797 else if (gfc_real_kinds
[n
].c_float128
)
798 snprintf (name
, sizeof (name
), "%s%s%s",
799 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
805 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
806 ts
->type
== BT_COMPLEX
? 'c' : 'r',
811 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
813 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
814 vec_safe_push (argtypes
, type
);
816 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
817 fndecl
= build_decl (input_location
,
818 FUNCTION_DECL
, get_identifier (name
), type
);
820 /* Mark the decl as external. */
821 DECL_EXTERNAL (fndecl
) = 1;
822 TREE_PUBLIC (fndecl
) = 1;
824 /* Mark it __attribute__((const)), if possible. */
825 TREE_READONLY (fndecl
) = m
->is_constant
;
827 rest_of_decl_compilation (fndecl
, 1, 0);
834 /* Convert an intrinsic function into an external or builtin call. */
837 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
839 gfc_intrinsic_map_t
*m
;
843 unsigned int num_args
;
846 id
= expr
->value
.function
.isym
->id
;
847 /* Find the entry for this function. */
848 for (m
= gfc_intrinsic_map
;
849 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
855 if (m
->id
== GFC_ISYM_NONE
)
857 internal_error ("Intrinsic function %s(%d) not recognized",
858 expr
->value
.function
.name
, id
);
861 /* Get the decl and generate the call. */
862 num_args
= gfc_intrinsic_argument_list_length (expr
);
863 args
= XALLOCAVEC (tree
, num_args
);
865 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
866 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
867 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
869 fndecl
= build_addr (fndecl
, current_function_decl
);
870 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
874 /* If bounds-checking is enabled, create code to verify at runtime that the
875 string lengths for both expressions are the same (needed for e.g. MERGE).
876 If bounds-checking is not enabled, does nothing. */
879 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
880 tree a
, tree b
, stmtblock_t
* target
)
885 /* If bounds-checking is disabled, do nothing. */
886 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
889 /* Compare the two string lengths. */
890 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
892 /* Output the runtime-check. */
893 name
= gfc_build_cstring_const (intr_name
);
894 name
= gfc_build_addr_expr (pchar_type_node
, name
);
895 gfc_trans_runtime_check (true, false, cond
, target
, where
,
896 "Unequal character lengths (%ld/%ld) in %s",
897 fold_convert (long_integer_type_node
, a
),
898 fold_convert (long_integer_type_node
, b
), name
);
902 /* The EXPONENT(s) intrinsic function is translated into
909 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
911 tree arg
, type
, res
, tmp
, frexp
;
913 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
914 expr
->value
.function
.actual
->expr
->ts
.kind
);
916 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
918 res
= gfc_create_var (integer_type_node
, NULL
);
919 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
920 gfc_build_addr_expr (NULL_TREE
, res
));
921 gfc_add_expr_to_block (&se
->pre
, tmp
);
923 type
= gfc_typenode_for_spec (&expr
->ts
);
924 se
->expr
= fold_convert (type
, res
);
929 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
932 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
933 lbound
, ubound
, extent
, ml
;
937 /* The case -fcoarray=single is handled elsewhere. */
938 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
940 gfc_init_coarray_decl (false);
942 /* Argument-free version: THIS_IMAGE(). */
943 if (expr
->value
.function
.actual
->expr
== NULL
)
945 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
946 gfort_gvar_caf_this_image
);
950 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
952 type
= gfc_get_int_type (gfc_default_integer_kind
);
953 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
954 rank
= expr
->value
.function
.actual
->expr
->rank
;
956 /* Obtain the descriptor of the COARRAY. */
957 gfc_init_se (&argse
, NULL
);
958 argse
.want_coarray
= 1;
959 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
960 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
961 gfc_add_block_to_block (&se
->post
, &argse
.post
);
966 /* Create an implicit second parameter from the loop variable. */
967 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
968 gcc_assert (corank
> 0);
969 gcc_assert (se
->loop
->dimen
== 1);
970 gcc_assert (se
->ss
->info
->expr
== expr
);
972 dim_arg
= se
->loop
->loopvar
[0];
973 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
974 gfc_array_index_type
, dim_arg
,
975 build_int_cst (TREE_TYPE (dim_arg
), 1));
976 gfc_advance_se_ss_chain (se
);
980 /* Use the passed DIM= argument. */
981 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
982 gfc_init_se (&argse
, NULL
);
983 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
984 gfc_array_index_type
);
985 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
986 dim_arg
= argse
.expr
;
988 if (INTEGER_CST_P (dim_arg
))
992 hi
= TREE_INT_CST_HIGH (dim_arg
);
993 co_dim
= TREE_INT_CST_LOW (dim_arg
);
995 || co_dim
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
996 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
997 "dimension index", expr
->value
.function
.isym
->name
,
1000 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1002 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1003 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1005 build_int_cst (TREE_TYPE (dim_arg
), 1));
1006 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1007 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1009 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1010 boolean_type_node
, cond
, tmp
);
1011 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1016 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1017 one always has a dim_arg argument.
1019 m = this_image() - 1
1022 sub(1) = m + lcobound(corank)
1026 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1029 extent = gfc_extent(i)
1037 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1038 : m + lcobound(corank)
1041 /* this_image () - 1. */
1042 tmp
= fold_convert (type
, gfort_gvar_caf_this_image
);
1043 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, tmp
,
1044 build_int_cst (type
, 1));
1047 /* sub(1) = m + lcobound(corank). */
1048 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1049 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1051 lbound
= fold_convert (type
, lbound
);
1052 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1058 m
= gfc_create_var (type
, NULL
);
1059 ml
= gfc_create_var (type
, NULL
);
1060 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1061 min_var
= gfc_create_var (integer_type_node
, NULL
);
1063 /* m = this_image () - 1. */
1064 gfc_add_modify (&se
->pre
, m
, tmp
);
1066 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1067 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1068 fold_convert (integer_type_node
, dim_arg
),
1069 build_int_cst (integer_type_node
, rank
- 1));
1070 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1071 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1073 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1076 tmp
= build_int_cst (integer_type_node
, rank
);
1077 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1079 exit_label
= gfc_build_label_decl (NULL_TREE
);
1080 TREE_USED (exit_label
) = 1;
1083 gfc_init_block (&loop
);
1086 gfc_add_modify (&loop
, ml
, m
);
1089 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1090 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1091 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1092 extent
= fold_convert (type
, extent
);
1095 gfc_add_modify (&loop
, m
,
1096 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1099 /* Exit condition: if (i >= min_var) goto exit_label. */
1100 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1102 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1103 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1104 build_empty_stmt (input_location
));
1105 gfc_add_expr_to_block (&loop
, tmp
);
1107 /* Increment loop variable: i++. */
1108 gfc_add_modify (&loop
, loop_var
,
1109 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1111 build_int_cst (integer_type_node
, 1)));
1113 /* Making the loop... actually loop! */
1114 tmp
= gfc_finish_block (&loop
);
1115 tmp
= build1_v (LOOP_EXPR
, tmp
);
1116 gfc_add_expr_to_block (&se
->pre
, tmp
);
1118 /* The exit label. */
1119 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1120 gfc_add_expr_to_block (&se
->pre
, tmp
);
1122 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1123 : m + lcobound(corank) */
1125 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1126 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1128 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1129 fold_build2_loc (input_location
, PLUS_EXPR
,
1130 gfc_array_index_type
, dim_arg
,
1131 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1132 lbound
= fold_convert (type
, lbound
);
1134 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1135 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1137 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1139 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1140 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1146 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1148 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1150 gfc_se argse
, subse
;
1151 int rank
, corank
, codim
;
1153 type
= gfc_get_int_type (gfc_default_integer_kind
);
1154 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1155 rank
= expr
->value
.function
.actual
->expr
->rank
;
1157 /* Obtain the descriptor of the COARRAY. */
1158 gfc_init_se (&argse
, NULL
);
1159 argse
.want_coarray
= 1;
1160 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1161 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1162 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1165 /* Obtain a handle to the SUB argument. */
1166 gfc_init_se (&subse
, NULL
);
1167 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1168 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1169 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1170 subdesc
= build_fold_indirect_ref_loc (input_location
,
1171 gfc_conv_descriptor_data_get (subse
.expr
));
1173 /* Fortran 2008 does not require that the values remain in the cobounds,
1174 thus we need explicitly check this - and return 0 if they are exceeded. */
1176 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1177 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1178 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1179 fold_convert (gfc_array_index_type
, tmp
),
1182 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1184 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1185 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1186 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1187 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1188 fold_convert (gfc_array_index_type
, tmp
),
1190 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1191 boolean_type_node
, invalid_bound
, cond
);
1192 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1193 fold_convert (gfc_array_index_type
, tmp
),
1195 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1196 boolean_type_node
, invalid_bound
, cond
);
1199 invalid_bound
= gfc_unlikely (invalid_bound
);
1202 /* See Fortran 2008, C.10 for the following algorithm. */
1204 /* coindex = sub(corank) - lcobound(n). */
1205 coindex
= fold_convert (gfc_array_index_type
,
1206 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1208 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1209 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1210 fold_convert (gfc_array_index_type
, coindex
),
1213 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1215 tree extent
, ubound
;
1217 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1218 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1219 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1220 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1222 /* coindex *= extent. */
1223 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1224 gfc_array_index_type
, coindex
, extent
);
1226 /* coindex += sub(codim). */
1227 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1228 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1229 gfc_array_index_type
, coindex
,
1230 fold_convert (gfc_array_index_type
, tmp
));
1232 /* coindex -= lbound(codim). */
1233 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1234 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1235 gfc_array_index_type
, coindex
, lbound
);
1238 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1239 fold_convert(type
, coindex
),
1240 build_int_cst (type
, 1));
1242 /* Return 0 if "coindex" exceeds num_images(). */
1244 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1245 num_images
= build_int_cst (type
, 1);
1248 gfc_init_coarray_decl (false);
1249 num_images
= fold_convert (type
, gfort_gvar_caf_num_images
);
1252 tmp
= gfc_create_var (type
, NULL
);
1253 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1255 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1257 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1259 fold_convert (boolean_type_node
, invalid_bound
));
1260 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1261 build_int_cst (type
, 0), tmp
);
1266 trans_num_images (gfc_se
* se
)
1268 gfc_init_coarray_decl (false);
1269 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1270 gfort_gvar_caf_num_images
);
1275 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1279 gfc_init_se (&argse
, NULL
);
1280 argse
.data_not_needed
= 1;
1281 argse
.descriptor_only
= 1;
1283 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1284 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1285 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1287 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1291 /* Evaluate a single upper or lower bound. */
1292 /* TODO: bound intrinsic generates way too much unnecessary code. */
1295 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1297 gfc_actual_arglist
*arg
;
1298 gfc_actual_arglist
*arg2
;
1303 tree cond
, cond1
, cond3
, cond4
, size
;
1307 gfc_array_spec
* as
;
1308 bool assumed_rank_lb_one
;
1310 arg
= expr
->value
.function
.actual
;
1315 /* Create an implicit second parameter from the loop variable. */
1316 gcc_assert (!arg2
->expr
);
1317 gcc_assert (se
->loop
->dimen
== 1);
1318 gcc_assert (se
->ss
->info
->expr
== expr
);
1319 gfc_advance_se_ss_chain (se
);
1320 bound
= se
->loop
->loopvar
[0];
1321 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1322 gfc_array_index_type
, bound
,
1327 /* use the passed argument. */
1328 gcc_assert (arg2
->expr
);
1329 gfc_init_se (&argse
, NULL
);
1330 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1331 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1333 /* Convert from one based to zero based. */
1334 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1335 gfc_array_index_type
, bound
,
1336 gfc_index_one_node
);
1339 /* TODO: don't re-evaluate the descriptor on each iteration. */
1340 /* Get a descriptor for the first parameter. */
1341 gfc_init_se (&argse
, NULL
);
1342 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1343 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1344 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1348 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1350 if (INTEGER_CST_P (bound
))
1354 hi
= TREE_INT_CST_HIGH (bound
);
1355 low
= TREE_INT_CST_LOW (bound
);
1357 || ((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1358 && low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1359 || low
> GFC_MAX_DIMENSIONS
)
1360 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1361 "dimension index", upper
? "UBOUND" : "LBOUND",
1365 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1367 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1369 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1370 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1371 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1372 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1373 tmp
= gfc_conv_descriptor_rank (desc
);
1375 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1376 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1377 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1378 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1379 boolean_type_node
, cond
, tmp
);
1380 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1385 /* Take care of the lbound shift for assumed-rank arrays, which are
1386 nonallocatable and nonpointers. Those has a lbound of 1. */
1387 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1388 && ((arg
->expr
->ts
.type
!= BT_CLASS
1389 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1390 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1391 || (arg
->expr
->ts
.type
== BT_CLASS
1392 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1393 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1395 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1396 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1398 /* 13.14.53: Result value for LBOUND
1400 Case (i): For an array section or for an array expression other than a
1401 whole array or array structure component, LBOUND(ARRAY, DIM)
1402 has the value 1. For a whole array or array structure
1403 component, LBOUND(ARRAY, DIM) has the value:
1404 (a) equal to the lower bound for subscript DIM of ARRAY if
1405 dimension DIM of ARRAY does not have extent zero
1406 or if ARRAY is an assumed-size array of rank DIM,
1409 13.14.113: Result value for UBOUND
1411 Case (i): For an array section or for an array expression other than a
1412 whole array or array structure component, UBOUND(ARRAY, DIM)
1413 has the value equal to the number of elements in the given
1414 dimension; otherwise, it has a value equal to the upper bound
1415 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1416 not have size zero and has value zero if dimension DIM has
1419 if (!upper
&& assumed_rank_lb_one
)
1420 se
->expr
= gfc_index_one_node
;
1423 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1425 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1427 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1428 stride
, gfc_index_zero_node
);
1429 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1430 boolean_type_node
, cond3
, cond1
);
1431 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1432 stride
, gfc_index_zero_node
);
1437 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1438 boolean_type_node
, cond3
, cond4
);
1439 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1440 gfc_index_one_node
, lbound
);
1441 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1442 boolean_type_node
, cond4
, cond5
);
1444 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1445 boolean_type_node
, cond
, cond5
);
1447 if (assumed_rank_lb_one
)
1449 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1450 gfc_array_index_type
, ubound
, lbound
);
1451 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1452 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1457 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1458 gfc_array_index_type
, cond
,
1459 tmp
, gfc_index_zero_node
);
1463 if (as
->type
== AS_ASSUMED_SIZE
)
1464 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1465 bound
, build_int_cst (TREE_TYPE (bound
),
1466 arg
->expr
->rank
- 1));
1468 cond
= boolean_false_node
;
1470 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1471 boolean_type_node
, cond3
, cond4
);
1472 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1473 boolean_type_node
, cond
, cond1
);
1475 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1476 gfc_array_index_type
, cond
,
1477 lbound
, gfc_index_one_node
);
1484 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1485 gfc_array_index_type
, ubound
, lbound
);
1486 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1487 gfc_array_index_type
, size
,
1488 gfc_index_one_node
);
1489 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1490 gfc_array_index_type
, se
->expr
,
1491 gfc_index_zero_node
);
1494 se
->expr
= gfc_index_one_node
;
1497 type
= gfc_typenode_for_spec (&expr
->ts
);
1498 se
->expr
= convert (type
, se
->expr
);
1503 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1505 gfc_actual_arglist
*arg
;
1506 gfc_actual_arglist
*arg2
;
1508 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1512 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1513 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1514 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1516 arg
= expr
->value
.function
.actual
;
1519 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1520 corank
= gfc_get_corank (arg
->expr
);
1522 gfc_init_se (&argse
, NULL
);
1523 argse
.want_coarray
= 1;
1525 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1526 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1527 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1532 /* Create an implicit second parameter from the loop variable. */
1533 gcc_assert (!arg2
->expr
);
1534 gcc_assert (corank
> 0);
1535 gcc_assert (se
->loop
->dimen
== 1);
1536 gcc_assert (se
->ss
->info
->expr
== expr
);
1538 bound
= se
->loop
->loopvar
[0];
1539 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1540 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1541 gfc_advance_se_ss_chain (se
);
1545 /* use the passed argument. */
1546 gcc_assert (arg2
->expr
);
1547 gfc_init_se (&argse
, NULL
);
1548 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1549 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1552 if (INTEGER_CST_P (bound
))
1556 hi
= TREE_INT_CST_HIGH (bound
);
1557 low
= TREE_INT_CST_LOW (bound
);
1558 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1559 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1560 "dimension index", expr
->value
.function
.isym
->name
,
1563 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1565 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1566 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1567 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1568 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1569 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1571 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1572 boolean_type_node
, cond
, tmp
);
1573 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1578 /* Subtract 1 to get to zero based and add dimensions. */
1579 switch (arg
->expr
->rank
)
1582 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1583 gfc_array_index_type
, bound
,
1584 gfc_index_one_node
);
1588 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1589 gfc_array_index_type
, bound
,
1590 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1594 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1596 /* Handle UCOBOUND with special handling of the last codimension. */
1597 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1599 /* Last codimension: For -fcoarray=single just return
1600 the lcobound - otherwise add
1601 ceiling (real (num_images ()) / real (size)) - 1
1602 = (num_images () + size - 1) / size - 1
1603 = (num_images - 1) / size(),
1604 where size is the product of the extent of all but the last
1607 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1611 gfc_init_coarray_decl (false);
1612 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1614 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1615 gfc_array_index_type
,
1616 fold_convert (gfc_array_index_type
,
1617 gfort_gvar_caf_num_images
),
1618 build_int_cst (gfc_array_index_type
, 1));
1619 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1620 gfc_array_index_type
, tmp
,
1621 fold_convert (gfc_array_index_type
, cosize
));
1622 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1623 gfc_array_index_type
, resbound
, tmp
);
1625 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1627 /* ubound = lbound + num_images() - 1. */
1628 gfc_init_coarray_decl (false);
1629 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1630 gfc_array_index_type
,
1631 fold_convert (gfc_array_index_type
,
1632 gfort_gvar_caf_num_images
),
1633 build_int_cst (gfc_array_index_type
, 1));
1634 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1635 gfc_array_index_type
, resbound
, tmp
);
1640 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1642 build_int_cst (TREE_TYPE (bound
),
1643 arg
->expr
->rank
+ corank
- 1));
1645 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1646 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1647 gfc_array_index_type
, cond
,
1648 resbound
, resbound2
);
1651 se
->expr
= resbound
;
1654 se
->expr
= resbound
;
1656 type
= gfc_typenode_for_spec (&expr
->ts
);
1657 se
->expr
= convert (type
, se
->expr
);
1662 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
1664 gfc_actual_arglist
*array_arg
;
1665 gfc_actual_arglist
*dim_arg
;
1669 array_arg
= expr
->value
.function
.actual
;
1670 dim_arg
= array_arg
->next
;
1672 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
1674 gfc_init_se (&argse
, NULL
);
1675 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
1676 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1677 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1680 gcc_assert (dim_arg
->expr
);
1681 gfc_init_se (&argse
, NULL
);
1682 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
1683 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1684 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1685 argse
.expr
, gfc_index_one_node
);
1686 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
1691 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1695 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1697 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1701 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1706 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1707 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1716 /* Create a complex value from one or two real components. */
1719 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1725 unsigned int num_args
;
1727 num_args
= gfc_intrinsic_argument_list_length (expr
);
1728 args
= XALLOCAVEC (tree
, num_args
);
1730 type
= gfc_typenode_for_spec (&expr
->ts
);
1731 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1732 real
= convert (TREE_TYPE (type
), args
[0]);
1734 imag
= convert (TREE_TYPE (type
), args
[1]);
1735 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1737 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1738 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1739 imag
= convert (TREE_TYPE (type
), imag
);
1742 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1744 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1748 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1749 MODULO(A, P) = A - FLOOR (A / P) * P
1751 The obvious algorithms above are numerically instable for large
1752 arguments, hence these intrinsics are instead implemented via calls
1753 to the fmod family of functions. It is the responsibility of the
1754 user to ensure that the second argument is non-zero. */
1757 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1767 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1769 switch (expr
->ts
.type
)
1772 /* Integer case is easy, we've got a builtin op. */
1773 type
= TREE_TYPE (args
[0]);
1776 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1779 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1785 /* Check if we have a builtin fmod. */
1786 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1788 /* The builtin should always be available. */
1789 gcc_assert (fmod
!= NULL_TREE
);
1791 tmp
= build_addr (fmod
, current_function_decl
);
1792 se
->expr
= build_call_array_loc (input_location
,
1793 TREE_TYPE (TREE_TYPE (fmod
)),
1798 type
= TREE_TYPE (args
[0]);
1800 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1801 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1804 modulo = arg - floor (arg/arg2) * arg2
1806 In order to calculate the result accurately, we use the fmod
1807 function as follows.
1809 res = fmod (arg, arg2);
1812 if ((arg < 0) xor (arg2 < 0))
1816 res = copysign (0., arg2);
1818 => As two nested ternary exprs:
1820 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
1821 : copysign (0., arg2);
1825 zero
= gfc_build_const (type
, integer_zero_node
);
1826 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1827 if (!flag_signed_zeros
)
1829 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1831 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1833 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1834 boolean_type_node
, test
, test2
);
1835 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1837 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1838 boolean_type_node
, test
, test2
);
1839 test
= gfc_evaluate_now (test
, &se
->pre
);
1840 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1841 fold_build2_loc (input_location
,
1843 type
, tmp
, args
[1]),
1848 tree expr1
, copysign
, cscall
;
1849 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
1851 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1853 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1855 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1856 boolean_type_node
, test
, test2
);
1857 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
1858 fold_build2_loc (input_location
,
1860 type
, tmp
, args
[1]),
1862 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1864 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
1866 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1876 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1877 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1878 where the right shifts are logical (i.e. 0's are shifted in).
1879 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1880 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1882 DSHIFTL(I,J,BITSIZE) = J
1884 DSHIFTR(I,J,BITSIZE) = I. */
1887 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1889 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1890 tree args
[3], cond
, tmp
;
1893 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1895 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1896 type
= TREE_TYPE (args
[0]);
1897 bitsize
= TYPE_PRECISION (type
);
1898 utype
= unsigned_type_for (type
);
1899 stype
= TREE_TYPE (args
[2]);
1901 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1902 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1903 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1905 /* The generic case. */
1906 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1907 build_int_cst (stype
, bitsize
), shift
);
1908 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1909 arg1
, dshiftl
? shift
: tmp
);
1911 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1912 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1913 right
= fold_convert (type
, right
);
1915 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1917 /* Special cases. */
1918 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1919 build_int_cst (stype
, 0));
1920 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1921 dshiftl
? arg1
: arg2
, res
);
1923 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1924 build_int_cst (stype
, bitsize
));
1925 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1926 dshiftl
? arg2
: arg1
, res
);
1932 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1935 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1943 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1944 type
= TREE_TYPE (args
[0]);
1946 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1947 val
= gfc_evaluate_now (val
, &se
->pre
);
1949 zero
= gfc_build_const (type
, integer_zero_node
);
1950 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1951 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1955 /* SIGN(A, B) is absolute value of A times sign of B.
1956 The real value versions use library functions to ensure the correct
1957 handling of negative zero. Integer case implemented as:
1958 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1962 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1968 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1969 if (expr
->ts
.type
== BT_REAL
)
1973 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1974 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1976 /* We explicitly have to ignore the minus sign. We do so by using
1977 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1978 if (!gfc_option
.flag_sign_zero
1979 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1982 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1983 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1985 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1986 TREE_TYPE (args
[0]), cond
,
1987 build_call_expr_loc (input_location
, abs
, 1,
1989 build_call_expr_loc (input_location
, tmp
, 2,
1993 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1998 /* Having excluded floating point types, we know we are now dealing
1999 with signed integer types. */
2000 type
= TREE_TYPE (args
[0]);
2002 /* Args[0] is used multiple times below. */
2003 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2005 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2006 the signs of A and B are the same, and of all ones if they differ. */
2007 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2008 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2009 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2010 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2012 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2013 is all ones (i.e. -1). */
2014 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2015 fold_build2_loc (input_location
, PLUS_EXPR
,
2016 type
, args
[0], tmp
), tmp
);
2020 /* Test for the presence of an optional argument. */
2023 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2027 arg
= expr
->value
.function
.actual
->expr
;
2028 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2029 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2030 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2034 /* Calculate the double precision product of two single precision values. */
2037 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2042 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2044 /* Convert the args to double precision before multiplying. */
2045 type
= gfc_typenode_for_spec (&expr
->ts
);
2046 args
[0] = convert (type
, args
[0]);
2047 args
[1] = convert (type
, args
[1]);
2048 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2053 /* Return a length one character string containing an ascii character. */
2056 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2061 unsigned int num_args
;
2063 num_args
= gfc_intrinsic_argument_list_length (expr
);
2064 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2066 type
= gfc_get_char_type (expr
->ts
.kind
);
2067 var
= gfc_create_var (type
, "char");
2069 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2070 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2071 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2072 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2077 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2085 unsigned int num_args
;
2087 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2088 args
= XALLOCAVEC (tree
, num_args
);
2090 var
= gfc_create_var (pchar_type_node
, "pstr");
2091 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2093 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2094 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2095 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2097 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2098 tmp
= build_call_array_loc (input_location
,
2099 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2100 fndecl
, num_args
, args
);
2101 gfc_add_expr_to_block (&se
->pre
, tmp
);
2103 /* Free the temporary afterwards, if necessary. */
2104 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2105 len
, build_int_cst (TREE_TYPE (len
), 0));
2106 tmp
= gfc_call_free (var
);
2107 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2108 gfc_add_expr_to_block (&se
->post
, tmp
);
2111 se
->string_length
= len
;
2116 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2124 unsigned int num_args
;
2126 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2127 args
= XALLOCAVEC (tree
, num_args
);
2129 var
= gfc_create_var (pchar_type_node
, "pstr");
2130 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2132 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2133 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2134 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2136 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2137 tmp
= build_call_array_loc (input_location
,
2138 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2139 fndecl
, num_args
, args
);
2140 gfc_add_expr_to_block (&se
->pre
, tmp
);
2142 /* Free the temporary afterwards, if necessary. */
2143 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2144 len
, build_int_cst (TREE_TYPE (len
), 0));
2145 tmp
= gfc_call_free (var
);
2146 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2147 gfc_add_expr_to_block (&se
->post
, tmp
);
2150 se
->string_length
= len
;
2154 /* Return a character string containing the tty name. */
2157 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2165 unsigned int num_args
;
2167 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2168 args
= XALLOCAVEC (tree
, num_args
);
2170 var
= gfc_create_var (pchar_type_node
, "pstr");
2171 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2173 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2174 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2175 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2177 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2178 tmp
= build_call_array_loc (input_location
,
2179 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2180 fndecl
, num_args
, args
);
2181 gfc_add_expr_to_block (&se
->pre
, tmp
);
2183 /* Free the temporary afterwards, if necessary. */
2184 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2185 len
, build_int_cst (TREE_TYPE (len
), 0));
2186 tmp
= gfc_call_free (var
);
2187 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2188 gfc_add_expr_to_block (&se
->post
, tmp
);
2191 se
->string_length
= len
;
2195 /* Get the minimum/maximum value of all the parameters.
2196 minmax (a1, a2, a3, ...)
2199 if (a2 .op. mvar || isnan (mvar))
2201 if (a3 .op. mvar || isnan (mvar))
2208 /* TODO: Mismatching types can occur when specific names are used.
2209 These should be handled during resolution. */
2211 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2219 gfc_actual_arglist
*argexpr
;
2220 unsigned int i
, nargs
;
2222 nargs
= gfc_intrinsic_argument_list_length (expr
);
2223 args
= XALLOCAVEC (tree
, nargs
);
2225 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2226 type
= gfc_typenode_for_spec (&expr
->ts
);
2228 argexpr
= expr
->value
.function
.actual
;
2229 if (TREE_TYPE (args
[0]) != type
)
2230 args
[0] = convert (type
, args
[0]);
2231 /* Only evaluate the argument once. */
2232 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2233 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2235 mvar
= gfc_create_var (type
, "M");
2236 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2237 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2243 /* Handle absent optional arguments by ignoring the comparison. */
2244 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2245 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2246 && TREE_CODE (val
) == INDIRECT_REF
)
2247 cond
= fold_build2_loc (input_location
,
2248 NE_EXPR
, boolean_type_node
,
2249 TREE_OPERAND (val
, 0),
2250 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2255 /* Only evaluate the argument once. */
2256 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2257 val
= gfc_evaluate_now (val
, &se
->pre
);
2260 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2262 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2263 convert (type
, val
), mvar
);
2265 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2266 __builtin_isnan might be made dependent on that module being loaded,
2267 to help performance of programs that don't rely on IEEE semantics. */
2268 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2270 isnan
= build_call_expr_loc (input_location
,
2271 builtin_decl_explicit (BUILT_IN_ISNAN
),
2273 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2274 boolean_type_node
, tmp
,
2275 fold_convert (boolean_type_node
, isnan
));
2277 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2278 build_empty_stmt (input_location
));
2280 if (cond
!= NULL_TREE
)
2281 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2282 build_empty_stmt (input_location
));
2284 gfc_add_expr_to_block (&se
->pre
, tmp
);
2285 argexpr
= argexpr
->next
;
2291 /* Generate library calls for MIN and MAX intrinsics for character
2294 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2297 tree var
, len
, fndecl
, tmp
, cond
, function
;
2300 nargs
= gfc_intrinsic_argument_list_length (expr
);
2301 args
= XALLOCAVEC (tree
, nargs
+ 4);
2302 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2304 /* Create the result variables. */
2305 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2306 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2307 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2308 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2309 args
[2] = build_int_cst (integer_type_node
, op
);
2310 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2312 if (expr
->ts
.kind
== 1)
2313 function
= gfor_fndecl_string_minmax
;
2314 else if (expr
->ts
.kind
== 4)
2315 function
= gfor_fndecl_string_minmax_char4
;
2319 /* Make the function call. */
2320 fndecl
= build_addr (function
, current_function_decl
);
2321 tmp
= build_call_array_loc (input_location
,
2322 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2324 gfc_add_expr_to_block (&se
->pre
, tmp
);
2326 /* Free the temporary afterwards, if necessary. */
2327 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2328 len
, build_int_cst (TREE_TYPE (len
), 0));
2329 tmp
= gfc_call_free (var
);
2330 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2331 gfc_add_expr_to_block (&se
->post
, tmp
);
2334 se
->string_length
= len
;
2338 /* Create a symbol node for this intrinsic. The symbol from the frontend
2339 has the generic name. */
2342 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2346 /* TODO: Add symbols for intrinsic function to the global namespace. */
2347 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2348 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2351 sym
->attr
.external
= 1;
2352 sym
->attr
.function
= 1;
2353 sym
->attr
.always_explicit
= 1;
2354 sym
->attr
.proc
= PROC_INTRINSIC
;
2355 sym
->attr
.flavor
= FL_PROCEDURE
;
2359 sym
->attr
.dimension
= 1;
2360 sym
->as
= gfc_get_array_spec ();
2361 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2362 sym
->as
->rank
= expr
->rank
;
2365 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2370 /* Generate a call to an external intrinsic function. */
2372 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2375 vec
<tree
, va_gc
> *append_args
;
2377 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2380 gcc_assert (expr
->rank
> 0);
2382 gcc_assert (expr
->rank
== 0);
2384 sym
= gfc_get_symbol_for_expr (expr
);
2386 /* Calls to libgfortran_matmul need to be appended special arguments,
2387 to be able to call the BLAS ?gemm functions if required and possible. */
2389 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2390 && sym
->ts
.type
!= BT_LOGICAL
)
2392 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2394 if (gfc_option
.flag_external_blas
2395 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2396 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2400 if (sym
->ts
.type
== BT_REAL
)
2402 if (sym
->ts
.kind
== 4)
2403 gemm_fndecl
= gfor_fndecl_sgemm
;
2405 gemm_fndecl
= gfor_fndecl_dgemm
;
2409 if (sym
->ts
.kind
== 4)
2410 gemm_fndecl
= gfor_fndecl_cgemm
;
2412 gemm_fndecl
= gfor_fndecl_zgemm
;
2415 vec_alloc (append_args
, 3);
2416 append_args
->quick_push (build_int_cst (cint
, 1));
2417 append_args
->quick_push (build_int_cst (cint
,
2418 gfc_option
.blas_matmul_limit
));
2419 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
2424 vec_alloc (append_args
, 3);
2425 append_args
->quick_push (build_int_cst (cint
, 0));
2426 append_args
->quick_push (build_int_cst (cint
, 0));
2427 append_args
->quick_push (null_pointer_node
);
2431 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2433 gfc_free_symbol (sym
);
2436 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2456 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2465 gfc_actual_arglist
*actual
;
2472 gfc_conv_intrinsic_funcall (se
, expr
);
2476 actual
= expr
->value
.function
.actual
;
2477 type
= gfc_typenode_for_spec (&expr
->ts
);
2478 /* Initialize the result. */
2479 resvar
= gfc_create_var (type
, "test");
2481 tmp
= convert (type
, boolean_true_node
);
2483 tmp
= convert (type
, boolean_false_node
);
2484 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2486 /* Walk the arguments. */
2487 arrayss
= gfc_walk_expr (actual
->expr
);
2488 gcc_assert (arrayss
!= gfc_ss_terminator
);
2490 /* Initialize the scalarizer. */
2491 gfc_init_loopinfo (&loop
);
2492 exit_label
= gfc_build_label_decl (NULL_TREE
);
2493 TREE_USED (exit_label
) = 1;
2494 gfc_add_ss_to_loop (&loop
, arrayss
);
2496 /* Initialize the loop. */
2497 gfc_conv_ss_startstride (&loop
);
2498 gfc_conv_loop_setup (&loop
, &expr
->where
);
2500 gfc_mark_ss_chain_used (arrayss
, 1);
2501 /* Generate the loop body. */
2502 gfc_start_scalarized_body (&loop
, &body
);
2504 /* If the condition matches then set the return value. */
2505 gfc_start_block (&block
);
2507 tmp
= convert (type
, boolean_false_node
);
2509 tmp
= convert (type
, boolean_true_node
);
2510 gfc_add_modify (&block
, resvar
, tmp
);
2512 /* And break out of the loop. */
2513 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2514 gfc_add_expr_to_block (&block
, tmp
);
2516 found
= gfc_finish_block (&block
);
2518 /* Check this element. */
2519 gfc_init_se (&arrayse
, NULL
);
2520 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2521 arrayse
.ss
= arrayss
;
2522 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2524 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2525 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2526 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2527 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2528 gfc_add_expr_to_block (&body
, tmp
);
2529 gfc_add_block_to_block (&body
, &arrayse
.post
);
2531 gfc_trans_scalarizing_loops (&loop
, &body
);
2533 /* Add the exit label. */
2534 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2535 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2537 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2538 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2539 gfc_cleanup_loop (&loop
);
2544 /* COUNT(A) = Number of true elements in A. */
2546 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2553 gfc_actual_arglist
*actual
;
2559 gfc_conv_intrinsic_funcall (se
, expr
);
2563 actual
= expr
->value
.function
.actual
;
2565 type
= gfc_typenode_for_spec (&expr
->ts
);
2566 /* Initialize the result. */
2567 resvar
= gfc_create_var (type
, "count");
2568 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2570 /* Walk the arguments. */
2571 arrayss
= gfc_walk_expr (actual
->expr
);
2572 gcc_assert (arrayss
!= gfc_ss_terminator
);
2574 /* Initialize the scalarizer. */
2575 gfc_init_loopinfo (&loop
);
2576 gfc_add_ss_to_loop (&loop
, arrayss
);
2578 /* Initialize the loop. */
2579 gfc_conv_ss_startstride (&loop
);
2580 gfc_conv_loop_setup (&loop
, &expr
->where
);
2582 gfc_mark_ss_chain_used (arrayss
, 1);
2583 /* Generate the loop body. */
2584 gfc_start_scalarized_body (&loop
, &body
);
2586 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2587 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2588 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2590 gfc_init_se (&arrayse
, NULL
);
2591 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2592 arrayse
.ss
= arrayss
;
2593 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2594 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2595 build_empty_stmt (input_location
));
2597 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2598 gfc_add_expr_to_block (&body
, tmp
);
2599 gfc_add_block_to_block (&body
, &arrayse
.post
);
2601 gfc_trans_scalarizing_loops (&loop
, &body
);
2603 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2604 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2605 gfc_cleanup_loop (&loop
);
2611 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2612 struct and return the corresponding loopinfo. */
2614 static gfc_loopinfo
*
2615 enter_nested_loop (gfc_se
*se
)
2617 se
->ss
= se
->ss
->nested_ss
;
2618 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2620 return se
->ss
->loop
;
2624 /* Inline implementation of the sum and product intrinsics. */
2626 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2630 tree scale
= NULL_TREE
;
2635 gfc_loopinfo loop
, *ploop
;
2636 gfc_actual_arglist
*arg_array
, *arg_mask
;
2637 gfc_ss
*arrayss
= NULL
;
2638 gfc_ss
*maskss
= NULL
;
2642 gfc_expr
*arrayexpr
;
2647 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2653 type
= gfc_typenode_for_spec (&expr
->ts
);
2654 /* Initialize the result. */
2655 resvar
= gfc_create_var (type
, "val");
2660 scale
= gfc_create_var (type
, "scale");
2661 gfc_add_modify (&se
->pre
, scale
,
2662 gfc_build_const (type
, integer_one_node
));
2663 tmp
= gfc_build_const (type
, integer_zero_node
);
2665 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2666 tmp
= gfc_build_const (type
, integer_zero_node
);
2667 else if (op
== NE_EXPR
)
2669 tmp
= convert (type
, boolean_false_node
);
2670 else if (op
== BIT_AND_EXPR
)
2671 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2672 type
, integer_one_node
));
2674 tmp
= gfc_build_const (type
, integer_one_node
);
2676 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2678 arg_array
= expr
->value
.function
.actual
;
2680 arrayexpr
= arg_array
->expr
;
2682 if (op
== NE_EXPR
|| norm2
)
2683 /* PARITY and NORM2. */
2687 arg_mask
= arg_array
->next
->next
;
2688 gcc_assert (arg_mask
!= NULL
);
2689 maskexpr
= arg_mask
->expr
;
2692 if (expr
->rank
== 0)
2694 /* Walk the arguments. */
2695 arrayss
= gfc_walk_expr (arrayexpr
);
2696 gcc_assert (arrayss
!= gfc_ss_terminator
);
2698 if (maskexpr
&& maskexpr
->rank
> 0)
2700 maskss
= gfc_walk_expr (maskexpr
);
2701 gcc_assert (maskss
!= gfc_ss_terminator
);
2706 /* Initialize the scalarizer. */
2707 gfc_init_loopinfo (&loop
);
2708 gfc_add_ss_to_loop (&loop
, arrayss
);
2709 if (maskexpr
&& maskexpr
->rank
> 0)
2710 gfc_add_ss_to_loop (&loop
, maskss
);
2712 /* Initialize the loop. */
2713 gfc_conv_ss_startstride (&loop
);
2714 gfc_conv_loop_setup (&loop
, &expr
->where
);
2716 gfc_mark_ss_chain_used (arrayss
, 1);
2717 if (maskexpr
&& maskexpr
->rank
> 0)
2718 gfc_mark_ss_chain_used (maskss
, 1);
2723 /* All the work has been done in the parent loops. */
2724 ploop
= enter_nested_loop (se
);
2728 /* Generate the loop body. */
2729 gfc_start_scalarized_body (ploop
, &body
);
2731 /* If we have a mask, only add this element if the mask is set. */
2732 if (maskexpr
&& maskexpr
->rank
> 0)
2734 gfc_init_se (&maskse
, parent_se
);
2735 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2736 if (expr
->rank
== 0)
2738 gfc_conv_expr_val (&maskse
, maskexpr
);
2739 gfc_add_block_to_block (&body
, &maskse
.pre
);
2741 gfc_start_block (&block
);
2744 gfc_init_block (&block
);
2746 /* Do the actual summation/product. */
2747 gfc_init_se (&arrayse
, parent_se
);
2748 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2749 if (expr
->rank
== 0)
2750 arrayse
.ss
= arrayss
;
2751 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2752 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2756 /* if (x (i) != 0.0)
2762 result = 1.0 + result * val * val;
2768 result += val * val;
2771 tree res1
, res2
, cond
, absX
, val
;
2772 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2774 gfc_init_block (&ifblock1
);
2776 absX
= gfc_create_var (type
, "absX");
2777 gfc_add_modify (&ifblock1
, absX
,
2778 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2780 val
= gfc_create_var (type
, "val");
2781 gfc_add_expr_to_block (&ifblock1
, val
);
2783 gfc_init_block (&ifblock2
);
2784 gfc_add_modify (&ifblock2
, val
,
2785 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2787 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2788 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2789 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2790 gfc_build_const (type
, integer_one_node
));
2791 gfc_add_modify (&ifblock2
, resvar
, res1
);
2792 gfc_add_modify (&ifblock2
, scale
, absX
);
2793 res1
= gfc_finish_block (&ifblock2
);
2795 gfc_init_block (&ifblock3
);
2796 gfc_add_modify (&ifblock3
, val
,
2797 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2799 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2800 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2801 gfc_add_modify (&ifblock3
, resvar
, res2
);
2802 res2
= gfc_finish_block (&ifblock3
);
2804 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2806 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2807 gfc_add_expr_to_block (&ifblock1
, tmp
);
2808 tmp
= gfc_finish_block (&ifblock1
);
2810 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2812 gfc_build_const (type
, integer_zero_node
));
2814 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2815 gfc_add_expr_to_block (&block
, tmp
);
2819 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2820 gfc_add_modify (&block
, resvar
, tmp
);
2823 gfc_add_block_to_block (&block
, &arrayse
.post
);
2825 if (maskexpr
&& maskexpr
->rank
> 0)
2827 /* We enclose the above in if (mask) {...} . */
2829 tmp
= gfc_finish_block (&block
);
2830 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2831 build_empty_stmt (input_location
));
2834 tmp
= gfc_finish_block (&block
);
2835 gfc_add_expr_to_block (&body
, tmp
);
2837 gfc_trans_scalarizing_loops (ploop
, &body
);
2839 /* For a scalar mask, enclose the loop in an if statement. */
2840 if (maskexpr
&& maskexpr
->rank
== 0)
2842 gfc_init_block (&block
);
2843 gfc_add_block_to_block (&block
, &ploop
->pre
);
2844 gfc_add_block_to_block (&block
, &ploop
->post
);
2845 tmp
= gfc_finish_block (&block
);
2849 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2850 build_empty_stmt (input_location
));
2851 gfc_advance_se_ss_chain (se
);
2855 gcc_assert (expr
->rank
== 0);
2856 gfc_init_se (&maskse
, NULL
);
2857 gfc_conv_expr_val (&maskse
, maskexpr
);
2858 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2859 build_empty_stmt (input_location
));
2862 gfc_add_expr_to_block (&block
, tmp
);
2863 gfc_add_block_to_block (&se
->pre
, &block
);
2864 gcc_assert (se
->post
.head
== NULL
);
2868 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2869 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2872 if (expr
->rank
== 0)
2873 gfc_cleanup_loop (ploop
);
2877 /* result = scale * sqrt(result). */
2879 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2880 resvar
= build_call_expr_loc (input_location
,
2882 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2889 /* Inline implementation of the dot_product intrinsic. This function
2890 is based on gfc_conv_intrinsic_arith (the previous function). */
2892 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2900 gfc_actual_arglist
*actual
;
2901 gfc_ss
*arrayss1
, *arrayss2
;
2902 gfc_se arrayse1
, arrayse2
;
2903 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2905 type
= gfc_typenode_for_spec (&expr
->ts
);
2907 /* Initialize the result. */
2908 resvar
= gfc_create_var (type
, "val");
2909 if (expr
->ts
.type
== BT_LOGICAL
)
2910 tmp
= build_int_cst (type
, 0);
2912 tmp
= gfc_build_const (type
, integer_zero_node
);
2914 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2916 /* Walk argument #1. */
2917 actual
= expr
->value
.function
.actual
;
2918 arrayexpr1
= actual
->expr
;
2919 arrayss1
= gfc_walk_expr (arrayexpr1
);
2920 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2922 /* Walk argument #2. */
2923 actual
= actual
->next
;
2924 arrayexpr2
= actual
->expr
;
2925 arrayss2
= gfc_walk_expr (arrayexpr2
);
2926 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2928 /* Initialize the scalarizer. */
2929 gfc_init_loopinfo (&loop
);
2930 gfc_add_ss_to_loop (&loop
, arrayss1
);
2931 gfc_add_ss_to_loop (&loop
, arrayss2
);
2933 /* Initialize the loop. */
2934 gfc_conv_ss_startstride (&loop
);
2935 gfc_conv_loop_setup (&loop
, &expr
->where
);
2937 gfc_mark_ss_chain_used (arrayss1
, 1);
2938 gfc_mark_ss_chain_used (arrayss2
, 1);
2940 /* Generate the loop body. */
2941 gfc_start_scalarized_body (&loop
, &body
);
2942 gfc_init_block (&block
);
2944 /* Make the tree expression for [conjg(]array1[)]. */
2945 gfc_init_se (&arrayse1
, NULL
);
2946 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2947 arrayse1
.ss
= arrayss1
;
2948 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2949 if (expr
->ts
.type
== BT_COMPLEX
)
2950 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2952 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2954 /* Make the tree expression for array2. */
2955 gfc_init_se (&arrayse2
, NULL
);
2956 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2957 arrayse2
.ss
= arrayss2
;
2958 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2959 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2961 /* Do the actual product and sum. */
2962 if (expr
->ts
.type
== BT_LOGICAL
)
2964 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2965 arrayse1
.expr
, arrayse2
.expr
);
2966 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2970 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2972 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2974 gfc_add_modify (&block
, resvar
, tmp
);
2976 /* Finish up the loop block and the loop. */
2977 tmp
= gfc_finish_block (&block
);
2978 gfc_add_expr_to_block (&body
, tmp
);
2980 gfc_trans_scalarizing_loops (&loop
, &body
);
2981 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2982 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2983 gfc_cleanup_loop (&loop
);
2989 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2990 we need to handle. For performance reasons we sometimes create two
2991 loops instead of one, where the second one is much simpler.
2992 Examples for minloc intrinsic:
2993 1) Result is an array, a call is generated
2994 2) Array mask is used and NaNs need to be supported:
3000 if (pos == 0) pos = S + (1 - from);
3001 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3008 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3012 3) NaNs need to be supported, but it is known at compile time or cheaply
3013 at runtime whether array is nonempty or not:
3018 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3021 if (from <= to) pos = 1;
3025 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3029 4) NaNs aren't supported, array mask is used:
3030 limit = infinities_supported ? Infinity : huge (limit);
3034 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3040 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3044 5) Same without array mask:
3045 limit = infinities_supported ? Infinity : huge (limit);
3046 pos = (from <= to) ? 1 : 0;
3049 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3052 For 3) and 5), if mask is scalar, this all goes into a conditional,
3053 setting pos = 0; in the else branch. */
3056 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3060 stmtblock_t ifblock
;
3061 stmtblock_t elseblock
;
3072 gfc_actual_arglist
*actual
;
3077 gfc_expr
*arrayexpr
;
3084 gfc_conv_intrinsic_funcall (se
, expr
);
3088 /* Initialize the result. */
3089 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3090 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3091 type
= gfc_typenode_for_spec (&expr
->ts
);
3093 /* Walk the arguments. */
3094 actual
= expr
->value
.function
.actual
;
3095 arrayexpr
= actual
->expr
;
3096 arrayss
= gfc_walk_expr (arrayexpr
);
3097 gcc_assert (arrayss
!= gfc_ss_terminator
);
3099 actual
= actual
->next
->next
;
3100 gcc_assert (actual
);
3101 maskexpr
= actual
->expr
;
3103 if (maskexpr
&& maskexpr
->rank
!= 0)
3105 maskss
= gfc_walk_expr (maskexpr
);
3106 gcc_assert (maskss
!= gfc_ss_terminator
);
3111 if (gfc_array_size (arrayexpr
, &asize
))
3113 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3115 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3116 boolean_type_node
, nonempty
,
3117 gfc_index_zero_node
);
3122 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3123 switch (arrayexpr
->ts
.type
)
3126 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3130 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3131 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3132 arrayexpr
->ts
.kind
);
3139 /* We start with the most negative possible value for MAXLOC, and the most
3140 positive possible value for MINLOC. The most negative possible value is
3141 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3142 possible value is HUGE in both cases. */
3144 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3145 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3146 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3147 build_int_cst (type
, 1));
3149 gfc_add_modify (&se
->pre
, limit
, tmp
);
3151 /* Initialize the scalarizer. */
3152 gfc_init_loopinfo (&loop
);
3153 gfc_add_ss_to_loop (&loop
, arrayss
);
3155 gfc_add_ss_to_loop (&loop
, maskss
);
3157 /* Initialize the loop. */
3158 gfc_conv_ss_startstride (&loop
);
3160 /* The code generated can have more than one loop in sequence (see the
3161 comment at the function header). This doesn't work well with the
3162 scalarizer, which changes arrays' offset when the scalarization loops
3163 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3164 are currently inlined in the scalar case only (for which loop is of rank
3165 one). As there is no dependency to care about in that case, there is no
3166 temporary, so that we can use the scalarizer temporary code to handle
3167 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3168 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3170 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3171 should eventually go away. We could either create two loops properly,
3172 or find another way to save/restore the array offsets between the two
3173 loops (without conflicting with temporary management), or use a single
3174 loop minmaxloc implementation. See PR 31067. */
3175 loop
.temp_dim
= loop
.dimen
;
3176 gfc_conv_loop_setup (&loop
, &expr
->where
);
3178 gcc_assert (loop
.dimen
== 1);
3179 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3180 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3181 loop
.from
[0], loop
.to
[0]);
3185 /* Initialize the position to zero, following Fortran 2003. We are free
3186 to do this because Fortran 95 allows the result of an entirely false
3187 mask to be processor dependent. If we know at compile time the array
3188 is non-empty and no MASK is used, we can initialize to 1 to simplify
3190 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3191 gfc_add_modify (&loop
.pre
, pos
,
3192 fold_build3_loc (input_location
, COND_EXPR
,
3193 gfc_array_index_type
,
3194 nonempty
, gfc_index_one_node
,
3195 gfc_index_zero_node
));
3198 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3199 lab1
= gfc_build_label_decl (NULL_TREE
);
3200 TREE_USED (lab1
) = 1;
3201 lab2
= gfc_build_label_decl (NULL_TREE
);
3202 TREE_USED (lab2
) = 1;
3205 /* An offset must be added to the loop
3206 counter to obtain the required position. */
3207 gcc_assert (loop
.from
[0]);
3209 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3210 gfc_index_one_node
, loop
.from
[0]);
3211 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3213 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3215 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3216 /* Generate the loop body. */
3217 gfc_start_scalarized_body (&loop
, &body
);
3219 /* If we have a mask, only check this element if the mask is set. */
3222 gfc_init_se (&maskse
, NULL
);
3223 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3225 gfc_conv_expr_val (&maskse
, maskexpr
);
3226 gfc_add_block_to_block (&body
, &maskse
.pre
);
3228 gfc_start_block (&block
);
3231 gfc_init_block (&block
);
3233 /* Compare with the current limit. */
3234 gfc_init_se (&arrayse
, NULL
);
3235 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3236 arrayse
.ss
= arrayss
;
3237 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3238 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3240 /* We do the following if this is a more extreme value. */
3241 gfc_start_block (&ifblock
);
3243 /* Assign the value to the limit... */
3244 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3246 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3248 stmtblock_t ifblock2
;
3251 gfc_start_block (&ifblock2
);
3252 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3253 loop
.loopvar
[0], offset
);
3254 gfc_add_modify (&ifblock2
, pos
, tmp
);
3255 ifbody2
= gfc_finish_block (&ifblock2
);
3256 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3257 gfc_index_zero_node
);
3258 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3259 build_empty_stmt (input_location
));
3260 gfc_add_expr_to_block (&block
, tmp
);
3263 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3264 loop
.loopvar
[0], offset
);
3265 gfc_add_modify (&ifblock
, pos
, tmp
);
3268 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3270 ifbody
= gfc_finish_block (&ifblock
);
3272 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3275 cond
= fold_build2_loc (input_location
,
3276 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3277 boolean_type_node
, arrayse
.expr
, limit
);
3279 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3280 arrayse
.expr
, limit
);
3282 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3283 build_empty_stmt (input_location
));
3285 gfc_add_expr_to_block (&block
, ifbody
);
3289 /* We enclose the above in if (mask) {...}. */
3290 tmp
= gfc_finish_block (&block
);
3292 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3293 build_empty_stmt (input_location
));
3296 tmp
= gfc_finish_block (&block
);
3297 gfc_add_expr_to_block (&body
, tmp
);
3301 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3303 if (HONOR_NANS (DECL_MODE (limit
)))
3305 if (nonempty
!= NULL
)
3307 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3308 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3309 build_empty_stmt (input_location
));
3310 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3314 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3315 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3317 /* If we have a mask, only check this element if the mask is set. */
3320 gfc_init_se (&maskse
, NULL
);
3321 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3323 gfc_conv_expr_val (&maskse
, maskexpr
);
3324 gfc_add_block_to_block (&body
, &maskse
.pre
);
3326 gfc_start_block (&block
);
3329 gfc_init_block (&block
);
3331 /* Compare with the current limit. */
3332 gfc_init_se (&arrayse
, NULL
);
3333 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3334 arrayse
.ss
= arrayss
;
3335 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3336 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3338 /* We do the following if this is a more extreme value. */
3339 gfc_start_block (&ifblock
);
3341 /* Assign the value to the limit... */
3342 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3344 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3345 loop
.loopvar
[0], offset
);
3346 gfc_add_modify (&ifblock
, pos
, tmp
);
3348 ifbody
= gfc_finish_block (&ifblock
);
3350 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3351 arrayse
.expr
, limit
);
3353 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3354 build_empty_stmt (input_location
));
3355 gfc_add_expr_to_block (&block
, tmp
);
3359 /* We enclose the above in if (mask) {...}. */
3360 tmp
= gfc_finish_block (&block
);
3362 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3363 build_empty_stmt (input_location
));
3366 tmp
= gfc_finish_block (&block
);
3367 gfc_add_expr_to_block (&body
, tmp
);
3368 /* Avoid initializing loopvar[0] again, it should be left where
3369 it finished by the first loop. */
3370 loop
.from
[0] = loop
.loopvar
[0];
3373 gfc_trans_scalarizing_loops (&loop
, &body
);
3376 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3378 /* For a scalar mask, enclose the loop in an if statement. */
3379 if (maskexpr
&& maskss
== NULL
)
3381 gfc_init_se (&maskse
, NULL
);
3382 gfc_conv_expr_val (&maskse
, maskexpr
);
3383 gfc_init_block (&block
);
3384 gfc_add_block_to_block (&block
, &loop
.pre
);
3385 gfc_add_block_to_block (&block
, &loop
.post
);
3386 tmp
= gfc_finish_block (&block
);
3388 /* For the else part of the scalar mask, just initialize
3389 the pos variable the same way as above. */
3391 gfc_init_block (&elseblock
);
3392 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3393 elsetmp
= gfc_finish_block (&elseblock
);
3395 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3396 gfc_add_expr_to_block (&block
, tmp
);
3397 gfc_add_block_to_block (&se
->pre
, &block
);
3401 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3402 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3404 gfc_cleanup_loop (&loop
);
3406 se
->expr
= convert (type
, pos
);
3409 /* Emit code for minval or maxval intrinsic. There are many different cases
3410 we need to handle. For performance reasons we sometimes create two
3411 loops instead of one, where the second one is much simpler.
3412 Examples for minval intrinsic:
3413 1) Result is an array, a call is generated
3414 2) Array mask is used and NaNs need to be supported, rank 1:
3419 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3422 limit = nonempty ? NaN : huge (limit);
3424 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3425 3) NaNs need to be supported, but it is known at compile time or cheaply
3426 at runtime whether array is nonempty or not, rank 1:
3429 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3430 limit = (from <= to) ? NaN : huge (limit);
3432 while (S <= to) { limit = min (a[S], limit); S++; }
3433 4) Array mask is used and NaNs need to be supported, rank > 1:
3442 if (fast) limit = min (a[S1][S2], limit);
3445 if (a[S1][S2] <= limit) {
3456 limit = nonempty ? NaN : huge (limit);
3457 5) NaNs need to be supported, but it is known at compile time or cheaply
3458 at runtime whether array is nonempty or not, rank > 1:
3465 if (fast) limit = min (a[S1][S2], limit);
3467 if (a[S1][S2] <= limit) {
3477 limit = (nonempty_array) ? NaN : huge (limit);
3478 6) NaNs aren't supported, but infinities are. Array mask is used:
3483 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3486 limit = nonempty ? limit : huge (limit);
3487 7) Same without array mask:
3490 while (S <= to) { limit = min (a[S], limit); S++; }
3491 limit = (from <= to) ? limit : huge (limit);
3492 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3493 limit = huge (limit);
3495 while (S <= to) { limit = min (a[S], limit); S++); }
3497 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3498 with array mask instead).
3499 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3500 setting limit = huge (limit); in the else branch. */
3503 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3513 tree huge_cst
= NULL
, nan_cst
= NULL
;
3515 stmtblock_t block
, block2
;
3517 gfc_actual_arglist
*actual
;
3522 gfc_expr
*arrayexpr
;
3528 gfc_conv_intrinsic_funcall (se
, expr
);
3532 type
= gfc_typenode_for_spec (&expr
->ts
);
3533 /* Initialize the result. */
3534 limit
= gfc_create_var (type
, "limit");
3535 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3536 switch (expr
->ts
.type
)
3539 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3541 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3543 REAL_VALUE_TYPE real
;
3545 tmp
= build_real (type
, real
);
3549 if (HONOR_NANS (DECL_MODE (limit
)))
3551 REAL_VALUE_TYPE real
;
3552 real_nan (&real
, "", 1, DECL_MODE (limit
));
3553 nan_cst
= build_real (type
, real
);
3558 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3565 /* We start with the most negative possible value for MAXVAL, and the most
3566 positive possible value for MINVAL. The most negative possible value is
3567 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3568 possible value is HUGE in both cases. */
3571 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3573 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3574 TREE_TYPE (huge_cst
), huge_cst
);
3577 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3578 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3579 tmp
, build_int_cst (type
, 1));
3581 gfc_add_modify (&se
->pre
, limit
, tmp
);
3583 /* Walk the arguments. */
3584 actual
= expr
->value
.function
.actual
;
3585 arrayexpr
= actual
->expr
;
3586 arrayss
= gfc_walk_expr (arrayexpr
);
3587 gcc_assert (arrayss
!= gfc_ss_terminator
);
3589 actual
= actual
->next
->next
;
3590 gcc_assert (actual
);
3591 maskexpr
= actual
->expr
;
3593 if (maskexpr
&& maskexpr
->rank
!= 0)
3595 maskss
= gfc_walk_expr (maskexpr
);
3596 gcc_assert (maskss
!= gfc_ss_terminator
);
3601 if (gfc_array_size (arrayexpr
, &asize
))
3603 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3605 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3606 boolean_type_node
, nonempty
,
3607 gfc_index_zero_node
);
3612 /* Initialize the scalarizer. */
3613 gfc_init_loopinfo (&loop
);
3614 gfc_add_ss_to_loop (&loop
, arrayss
);
3616 gfc_add_ss_to_loop (&loop
, maskss
);
3618 /* Initialize the loop. */
3619 gfc_conv_ss_startstride (&loop
);
3621 /* The code generated can have more than one loop in sequence (see the
3622 comment at the function header). This doesn't work well with the
3623 scalarizer, which changes arrays' offset when the scalarization loops
3624 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3625 are currently inlined in the scalar case only. As there is no dependency
3626 to care about in that case, there is no temporary, so that we can use the
3627 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3628 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3629 gfc_trans_scalarized_loop_boundary even later to restore offset.
3630 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3631 should eventually go away. We could either create two loops properly,
3632 or find another way to save/restore the array offsets between the two
3633 loops (without conflicting with temporary management), or use a single
3634 loop minmaxval implementation. See PR 31067. */
3635 loop
.temp_dim
= loop
.dimen
;
3636 gfc_conv_loop_setup (&loop
, &expr
->where
);
3638 if (nonempty
== NULL
&& maskss
== NULL
3639 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3640 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3641 loop
.from
[0], loop
.to
[0]);
3642 nonempty_var
= NULL
;
3643 if (nonempty
== NULL
3644 && (HONOR_INFINITIES (DECL_MODE (limit
))
3645 || HONOR_NANS (DECL_MODE (limit
))))
3647 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3648 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3649 nonempty
= nonempty_var
;
3653 if (HONOR_NANS (DECL_MODE (limit
)))
3655 if (loop
.dimen
== 1)
3657 lab
= gfc_build_label_decl (NULL_TREE
);
3658 TREE_USED (lab
) = 1;
3662 fast
= gfc_create_var (boolean_type_node
, "fast");
3663 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3667 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3669 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3670 /* Generate the loop body. */
3671 gfc_start_scalarized_body (&loop
, &body
);
3673 /* If we have a mask, only add this element if the mask is set. */
3676 gfc_init_se (&maskse
, NULL
);
3677 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3679 gfc_conv_expr_val (&maskse
, maskexpr
);
3680 gfc_add_block_to_block (&body
, &maskse
.pre
);
3682 gfc_start_block (&block
);
3685 gfc_init_block (&block
);
3687 /* Compare with the current limit. */
3688 gfc_init_se (&arrayse
, NULL
);
3689 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3690 arrayse
.ss
= arrayss
;
3691 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3692 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3694 gfc_init_block (&block2
);
3697 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3699 if (HONOR_NANS (DECL_MODE (limit
)))
3701 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3702 boolean_type_node
, arrayse
.expr
, limit
);
3704 ifbody
= build1_v (GOTO_EXPR
, lab
);
3707 stmtblock_t ifblock
;
3709 gfc_init_block (&ifblock
);
3710 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3711 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3712 ifbody
= gfc_finish_block (&ifblock
);
3714 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3715 build_empty_stmt (input_location
));
3716 gfc_add_expr_to_block (&block2
, tmp
);
3720 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3722 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3724 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3725 arrayse
.expr
, limit
);
3726 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3727 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3728 build_empty_stmt (input_location
));
3729 gfc_add_expr_to_block (&block2
, tmp
);
3733 tmp
= fold_build2_loc (input_location
,
3734 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3735 type
, arrayse
.expr
, limit
);
3736 gfc_add_modify (&block2
, limit
, tmp
);
3742 tree elsebody
= gfc_finish_block (&block2
);
3744 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3746 if (HONOR_NANS (DECL_MODE (limit
))
3747 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3749 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3750 arrayse
.expr
, limit
);
3751 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3752 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3753 build_empty_stmt (input_location
));
3757 tmp
= fold_build2_loc (input_location
,
3758 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3759 type
, arrayse
.expr
, limit
);
3760 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3762 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3763 gfc_add_expr_to_block (&block
, tmp
);
3766 gfc_add_block_to_block (&block
, &block2
);
3768 gfc_add_block_to_block (&block
, &arrayse
.post
);
3770 tmp
= gfc_finish_block (&block
);
3772 /* We enclose the above in if (mask) {...}. */
3773 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3774 build_empty_stmt (input_location
));
3775 gfc_add_expr_to_block (&body
, tmp
);
3779 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3781 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3783 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3784 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3786 /* If we have a mask, only add this element if the mask is set. */
3789 gfc_init_se (&maskse
, NULL
);
3790 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3792 gfc_conv_expr_val (&maskse
, maskexpr
);
3793 gfc_add_block_to_block (&body
, &maskse
.pre
);
3795 gfc_start_block (&block
);
3798 gfc_init_block (&block
);
3800 /* Compare with the current limit. */
3801 gfc_init_se (&arrayse
, NULL
);
3802 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3803 arrayse
.ss
= arrayss
;
3804 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3805 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3807 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3809 if (HONOR_NANS (DECL_MODE (limit
))
3810 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3812 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3813 arrayse
.expr
, limit
);
3814 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3815 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3816 build_empty_stmt (input_location
));
3817 gfc_add_expr_to_block (&block
, tmp
);
3821 tmp
= fold_build2_loc (input_location
,
3822 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3823 type
, arrayse
.expr
, limit
);
3824 gfc_add_modify (&block
, limit
, tmp
);
3827 gfc_add_block_to_block (&block
, &arrayse
.post
);
3829 tmp
= gfc_finish_block (&block
);
3831 /* We enclose the above in if (mask) {...}. */
3832 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3833 build_empty_stmt (input_location
));
3834 gfc_add_expr_to_block (&body
, tmp
);
3835 /* Avoid initializing loopvar[0] again, it should be left where
3836 it finished by the first loop. */
3837 loop
.from
[0] = loop
.loopvar
[0];
3839 gfc_trans_scalarizing_loops (&loop
, &body
);
3843 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3845 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3846 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3848 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3850 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3852 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3854 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3857 /* For a scalar mask, enclose the loop in an if statement. */
3858 if (maskexpr
&& maskss
== NULL
)
3862 gfc_init_se (&maskse
, NULL
);
3863 gfc_conv_expr_val (&maskse
, maskexpr
);
3864 gfc_init_block (&block
);
3865 gfc_add_block_to_block (&block
, &loop
.pre
);
3866 gfc_add_block_to_block (&block
, &loop
.post
);
3867 tmp
= gfc_finish_block (&block
);
3869 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3870 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3872 else_stmt
= build_empty_stmt (input_location
);
3873 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3874 gfc_add_expr_to_block (&block
, tmp
);
3875 gfc_add_block_to_block (&se
->pre
, &block
);
3879 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3880 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3883 gfc_cleanup_loop (&loop
);
3888 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3890 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3896 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3897 type
= TREE_TYPE (args
[0]);
3899 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3900 build_int_cst (type
, 1), args
[1]);
3901 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3902 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3903 build_int_cst (type
, 0));
3904 type
= gfc_typenode_for_spec (&expr
->ts
);
3905 se
->expr
= convert (type
, tmp
);
3909 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3911 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3915 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3917 /* Convert both arguments to the unsigned type of the same size. */
3918 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3919 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3921 /* If they have unequal type size, convert to the larger one. */
3922 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3923 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3924 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3925 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3926 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3927 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3929 /* Now, we compare them. */
3930 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3935 /* Generate code to perform the specified operation. */
3937 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3941 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3942 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3948 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3952 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3953 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3954 TREE_TYPE (arg
), arg
);
3957 /* Set or clear a single bit. */
3959 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3966 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3967 type
= TREE_TYPE (args
[0]);
3969 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3970 build_int_cst (type
, 1), args
[1]);
3976 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3978 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3981 /* Extract a sequence of bits.
3982 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3984 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3991 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3992 type
= TREE_TYPE (args
[0]);
3994 mask
= build_int_cst (type
, -1);
3995 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3996 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3998 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4000 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4004 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4007 tree args
[2], type
, num_bits
, cond
;
4009 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4011 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4012 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4013 type
= TREE_TYPE (args
[0]);
4016 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4018 gcc_assert (right_shift
);
4020 se
->expr
= fold_build2_loc (input_location
,
4021 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4022 TREE_TYPE (args
[0]), args
[0], args
[1]);
4025 se
->expr
= fold_convert (type
, se
->expr
);
4027 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4028 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4030 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4031 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4034 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4035 build_int_cst (type
, 0), se
->expr
);
4038 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4040 : ((shift >= 0) ? i << shift : i >> -shift)
4041 where all shifts are logical shifts. */
4043 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4055 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4057 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4058 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4060 type
= TREE_TYPE (args
[0]);
4061 utype
= unsigned_type_for (type
);
4063 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4066 /* Left shift if positive. */
4067 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4069 /* Right shift if negative.
4070 We convert to an unsigned type because we want a logical shift.
4071 The standard doesn't define the case of shifting negative
4072 numbers, and we try to be compatible with other compilers, most
4073 notably g77, here. */
4074 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4075 utype
, convert (utype
, args
[0]), width
));
4077 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4078 build_int_cst (TREE_TYPE (args
[1]), 0));
4079 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4081 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4082 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4084 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4085 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4087 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4088 build_int_cst (type
, 0), tmp
);
4092 /* Circular shift. AKA rotate or barrel shift. */
4095 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4103 unsigned int num_args
;
4105 num_args
= gfc_intrinsic_argument_list_length (expr
);
4106 args
= XALLOCAVEC (tree
, num_args
);
4108 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4112 /* Use a library function for the 3 parameter version. */
4113 tree int4type
= gfc_get_int_type (4);
4115 type
= TREE_TYPE (args
[0]);
4116 /* We convert the first argument to at least 4 bytes, and
4117 convert back afterwards. This removes the need for library
4118 functions for all argument sizes, and function will be
4119 aligned to at least 32 bits, so there's no loss. */
4120 if (expr
->ts
.kind
< 4)
4121 args
[0] = convert (int4type
, args
[0]);
4123 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4124 need loads of library functions. They cannot have values >
4125 BIT_SIZE (I) so the conversion is safe. */
4126 args
[1] = convert (int4type
, args
[1]);
4127 args
[2] = convert (int4type
, args
[2]);
4129 switch (expr
->ts
.kind
)
4134 tmp
= gfor_fndecl_math_ishftc4
;
4137 tmp
= gfor_fndecl_math_ishftc8
;
4140 tmp
= gfor_fndecl_math_ishftc16
;
4145 se
->expr
= build_call_expr_loc (input_location
,
4146 tmp
, 3, args
[0], args
[1], args
[2]);
4147 /* Convert the result back to the original type, if we extended
4148 the first argument's width above. */
4149 if (expr
->ts
.kind
< 4)
4150 se
->expr
= convert (type
, se
->expr
);
4154 type
= TREE_TYPE (args
[0]);
4156 /* Evaluate arguments only once. */
4157 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4158 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4160 /* Rotate left if positive. */
4161 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4163 /* Rotate right if negative. */
4164 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4166 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4168 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4169 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4171 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4173 /* Do nothing if shift == 0. */
4174 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4176 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4181 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4182 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4184 The conditional expression is necessary because the result of LEADZ(0)
4185 is defined, but the result of __builtin_clz(0) is undefined for most
4188 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4189 difference in bit size between the argument of LEADZ and the C int. */
4192 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4204 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4205 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4207 /* Which variant of __builtin_clz* should we call? */
4208 if (argsize
<= INT_TYPE_SIZE
)
4210 arg_type
= unsigned_type_node
;
4211 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4213 else if (argsize
<= LONG_TYPE_SIZE
)
4215 arg_type
= long_unsigned_type_node
;
4216 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4218 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4220 arg_type
= long_long_unsigned_type_node
;
4221 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4225 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4226 arg_type
= gfc_build_uint_type (argsize
);
4230 /* Convert the actual argument twice: first, to the unsigned type of the
4231 same size; then, to the proper argument type for the built-in
4232 function. But the return type is of the default INTEGER kind. */
4233 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4234 arg
= fold_convert (arg_type
, arg
);
4235 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4236 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4238 /* Compute LEADZ for the case i .ne. 0. */
4241 s
= TYPE_PRECISION (arg_type
) - argsize
;
4242 tmp
= fold_convert (result_type
,
4243 build_call_expr_loc (input_location
, func
,
4245 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4246 tmp
, build_int_cst (result_type
, s
));
4250 /* We end up here if the argument type is larger than 'long long'.
4251 We generate this code:
4253 if (x & (ULL_MAX << ULL_SIZE) != 0)
4254 return clzll ((unsigned long long) (x >> ULLSIZE));
4256 return ULL_SIZE + clzll ((unsigned long long) x);
4257 where ULL_MAX is the largest value that a ULL_MAX can hold
4258 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4259 is the bit-size of the long long type (64 in this example). */
4260 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4262 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4263 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4264 long_long_unsigned_type_node
,
4265 build_int_cst (long_long_unsigned_type_node
,
4268 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4269 fold_convert (arg_type
, ullmax
), ullsize
);
4270 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4272 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4273 cond
, build_int_cst (arg_type
, 0));
4275 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4277 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4278 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4279 tmp1
= fold_convert (result_type
,
4280 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4282 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4283 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4284 tmp2
= fold_convert (result_type
,
4285 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4286 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4289 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4293 /* Build BIT_SIZE. */
4294 bit_size
= build_int_cst (result_type
, argsize
);
4296 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4297 arg
, build_int_cst (arg_type
, 0));
4298 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4303 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4305 The conditional expression is necessary because the result of TRAILZ(0)
4306 is defined, but the result of __builtin_ctz(0) is undefined for most
4310 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4321 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4322 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4324 /* Which variant of __builtin_ctz* should we call? */
4325 if (argsize
<= INT_TYPE_SIZE
)
4327 arg_type
= unsigned_type_node
;
4328 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4330 else if (argsize
<= LONG_TYPE_SIZE
)
4332 arg_type
= long_unsigned_type_node
;
4333 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4335 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4337 arg_type
= long_long_unsigned_type_node
;
4338 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4342 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4343 arg_type
= gfc_build_uint_type (argsize
);
4347 /* Convert the actual argument twice: first, to the unsigned type of the
4348 same size; then, to the proper argument type for the built-in
4349 function. But the return type is of the default INTEGER kind. */
4350 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4351 arg
= fold_convert (arg_type
, arg
);
4352 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4353 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4355 /* Compute TRAILZ for the case i .ne. 0. */
4357 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4361 /* We end up here if the argument type is larger than 'long long'.
4362 We generate this code:
4364 if ((x & ULL_MAX) == 0)
4365 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4367 return ctzll ((unsigned long long) x);
4369 where ULL_MAX is the largest value that a ULL_MAX can hold
4370 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4371 is the bit-size of the long long type (64 in this example). */
4372 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4374 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4375 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4376 long_long_unsigned_type_node
,
4377 build_int_cst (long_long_unsigned_type_node
, 0));
4379 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4380 fold_convert (arg_type
, ullmax
));
4381 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4382 build_int_cst (arg_type
, 0));
4384 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4386 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4387 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4388 tmp1
= fold_convert (result_type
,
4389 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4390 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4393 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4394 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4395 tmp2
= fold_convert (result_type
,
4396 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4398 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4402 /* Build BIT_SIZE. */
4403 bit_size
= build_int_cst (result_type
, argsize
);
4405 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4406 arg
, build_int_cst (arg_type
, 0));
4407 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4411 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4412 for types larger than "long long", we call the long long built-in for
4413 the lower and higher bits and combine the result. */
4416 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4424 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4425 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4426 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4428 /* Which variant of the builtin should we call? */
4429 if (argsize
<= INT_TYPE_SIZE
)
4431 arg_type
= unsigned_type_node
;
4432 func
= builtin_decl_explicit (parity
4434 : BUILT_IN_POPCOUNT
);
4436 else if (argsize
<= LONG_TYPE_SIZE
)
4438 arg_type
= long_unsigned_type_node
;
4439 func
= builtin_decl_explicit (parity
4441 : BUILT_IN_POPCOUNTL
);
4443 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4445 arg_type
= long_long_unsigned_type_node
;
4446 func
= builtin_decl_explicit (parity
4448 : BUILT_IN_POPCOUNTLL
);
4452 /* Our argument type is larger than 'long long', which mean none
4453 of the POPCOUNT builtins covers it. We thus call the 'long long'
4454 variant multiple times, and add the results. */
4455 tree utype
, arg2
, call1
, call2
;
4457 /* For now, we only cover the case where argsize is twice as large
4459 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4461 func
= builtin_decl_explicit (parity
4463 : BUILT_IN_POPCOUNTLL
);
4465 /* Convert it to an integer, and store into a variable. */
4466 utype
= gfc_build_uint_type (argsize
);
4467 arg
= fold_convert (utype
, arg
);
4468 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4470 /* Call the builtin twice. */
4471 call1
= build_call_expr_loc (input_location
, func
, 1,
4472 fold_convert (long_long_unsigned_type_node
,
4475 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4476 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4477 call2
= build_call_expr_loc (input_location
, func
, 1,
4478 fold_convert (long_long_unsigned_type_node
,
4481 /* Combine the results. */
4483 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4486 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4492 /* Convert the actual argument twice: first, to the unsigned type of the
4493 same size; then, to the proper argument type for the built-in
4495 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4496 arg
= fold_convert (arg_type
, arg
);
4498 se
->expr
= fold_convert (result_type
,
4499 build_call_expr_loc (input_location
, func
, 1, arg
));
4503 /* Process an intrinsic with unspecified argument-types that has an optional
4504 argument (which could be of type character), e.g. EOSHIFT. For those, we
4505 need to append the string length of the optional argument if it is not
4506 present and the type is really character.
4507 primary specifies the position (starting at 1) of the non-optional argument
4508 specifying the type and optional gives the position of the optional
4509 argument in the arglist. */
4512 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4513 unsigned primary
, unsigned optional
)
4515 gfc_actual_arglist
* prim_arg
;
4516 gfc_actual_arglist
* opt_arg
;
4518 gfc_actual_arglist
* arg
;
4520 vec
<tree
, va_gc
> *append_args
;
4522 /* Find the two arguments given as position. */
4526 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4530 if (cur_pos
== primary
)
4532 if (cur_pos
== optional
)
4535 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4538 gcc_assert (prim_arg
);
4539 gcc_assert (prim_arg
->expr
);
4540 gcc_assert (opt_arg
);
4542 /* If we do have type CHARACTER and the optional argument is really absent,
4543 append a dummy 0 as string length. */
4545 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4549 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4550 vec_alloc (append_args
, 1);
4551 append_args
->quick_push (dummy
);
4554 /* Build the call itself. */
4555 sym
= gfc_get_symbol_for_expr (expr
);
4556 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4558 gfc_free_symbol (sym
);
4562 /* The length of a character string. */
4564 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4573 gcc_assert (!se
->ss
);
4575 arg
= expr
->value
.function
.actual
->expr
;
4577 type
= gfc_typenode_for_spec (&expr
->ts
);
4578 switch (arg
->expr_type
)
4581 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4585 /* Obtain the string length from the function used by
4586 trans-array.c(gfc_trans_array_constructor). */
4588 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4592 if (arg
->ref
== NULL
4593 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4595 /* This doesn't catch all cases.
4596 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4597 and the surrounding thread. */
4598 sym
= arg
->symtree
->n
.sym
;
4599 decl
= gfc_get_symbol_decl (sym
);
4600 if (decl
== current_function_decl
&& sym
->attr
.function
4601 && (sym
->result
== sym
))
4602 decl
= gfc_get_fake_result_decl (sym
, 0);
4604 len
= sym
->ts
.u
.cl
->backend_decl
;
4609 /* Otherwise fall through. */
4612 /* Anybody stupid enough to do this deserves inefficient code. */
4613 gfc_init_se (&argse
, se
);
4615 gfc_conv_expr (&argse
, arg
);
4617 gfc_conv_expr_descriptor (&argse
, arg
);
4618 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4619 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4620 len
= argse
.string_length
;
4623 se
->expr
= convert (type
, len
);
4626 /* The length of a character string not including trailing blanks. */
4628 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4630 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4631 tree args
[2], type
, fndecl
;
4633 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4634 type
= gfc_typenode_for_spec (&expr
->ts
);
4637 fndecl
= gfor_fndecl_string_len_trim
;
4639 fndecl
= gfor_fndecl_string_len_trim_char4
;
4643 se
->expr
= build_call_expr_loc (input_location
,
4644 fndecl
, 2, args
[0], args
[1]);
4645 se
->expr
= convert (type
, se
->expr
);
4649 /* Returns the starting position of a substring within a string. */
4652 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4655 tree logical4_type_node
= gfc_get_logical_type (4);
4659 unsigned int num_args
;
4661 args
= XALLOCAVEC (tree
, 5);
4663 /* Get number of arguments; characters count double due to the
4664 string length argument. Kind= is not passed to the library
4665 and thus ignored. */
4666 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4671 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4672 type
= gfc_typenode_for_spec (&expr
->ts
);
4675 args
[4] = build_int_cst (logical4_type_node
, 0);
4677 args
[4] = convert (logical4_type_node
, args
[4]);
4679 fndecl
= build_addr (function
, current_function_decl
);
4680 se
->expr
= build_call_array_loc (input_location
,
4681 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4683 se
->expr
= convert (type
, se
->expr
);
4687 /* The ascii value for a single character. */
4689 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4691 tree args
[2], type
, pchartype
;
4693 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4694 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4695 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4696 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4697 type
= gfc_typenode_for_spec (&expr
->ts
);
4699 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4701 se
->expr
= convert (type
, se
->expr
);
4705 /* Intrinsic ISNAN calls __builtin_isnan. */
4708 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4712 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4713 se
->expr
= build_call_expr_loc (input_location
,
4714 builtin_decl_explicit (BUILT_IN_ISNAN
),
4716 STRIP_TYPE_NOPS (se
->expr
);
4717 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4721 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4722 their argument against a constant integer value. */
4725 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4729 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4730 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4731 gfc_typenode_for_spec (&expr
->ts
),
4732 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4737 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4740 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4748 unsigned int num_args
;
4750 num_args
= gfc_intrinsic_argument_list_length (expr
);
4751 args
= XALLOCAVEC (tree
, num_args
);
4753 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4754 if (expr
->ts
.type
!= BT_CHARACTER
)
4762 /* We do the same as in the non-character case, but the argument
4763 list is different because of the string length arguments. We
4764 also have to set the string length for the result. */
4771 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4773 se
->string_length
= len
;
4775 type
= TREE_TYPE (tsource
);
4776 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4777 fold_convert (type
, fsource
));
4781 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4784 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4786 tree args
[3], mask
, type
;
4788 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4789 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4791 type
= TREE_TYPE (args
[0]);
4792 gcc_assert (TREE_TYPE (args
[1]) == type
);
4793 gcc_assert (TREE_TYPE (mask
) == type
);
4795 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4796 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4797 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4799 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4804 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4805 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4808 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4810 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4813 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4814 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4816 type
= gfc_get_int_type (expr
->ts
.kind
);
4817 utype
= unsigned_type_for (type
);
4819 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4820 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4822 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4823 build_int_cst (utype
, 0));
4827 /* Left-justified mask. */
4828 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4830 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4831 fold_convert (utype
, res
));
4833 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4834 smaller than type width. */
4835 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4836 build_int_cst (TREE_TYPE (arg
), 0));
4837 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4838 build_int_cst (utype
, 0), res
);
4842 /* Right-justified mask. */
4843 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4844 fold_convert (utype
, arg
));
4845 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4847 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4848 strictly smaller than type width. */
4849 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4851 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4852 cond
, allones
, res
);
4855 se
->expr
= fold_convert (type
, res
);
4859 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4861 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4863 tree arg
, type
, tmp
, frexp
;
4865 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4867 type
= gfc_typenode_for_spec (&expr
->ts
);
4868 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4869 tmp
= gfc_create_var (integer_type_node
, NULL
);
4870 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4871 fold_convert (type
, arg
),
4872 gfc_build_addr_expr (NULL_TREE
, tmp
));
4873 se
->expr
= fold_convert (type
, se
->expr
);
4877 /* NEAREST (s, dir) is translated into
4878 tmp = copysign (HUGE_VAL, dir);
4879 return nextafter (s, tmp);
4882 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4884 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4886 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4887 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4889 type
= gfc_typenode_for_spec (&expr
->ts
);
4890 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4892 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4893 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4894 fold_convert (type
, args
[1]));
4895 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4896 fold_convert (type
, args
[0]), tmp
);
4897 se
->expr
= fold_convert (type
, se
->expr
);
4901 /* SPACING (s) is translated into
4909 e = MAX_EXPR (e, emin);
4910 res = scalbn (1., e);
4914 where prec is the precision of s, gfc_real_kinds[k].digits,
4915 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4916 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4919 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4921 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4922 tree cond
, tmp
, frexp
, scalbn
;
4926 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4927 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
4928 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
4929 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4931 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4932 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4934 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4935 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4937 type
= gfc_typenode_for_spec (&expr
->ts
);
4938 e
= gfc_create_var (integer_type_node
, NULL
);
4939 res
= gfc_create_var (type
, NULL
);
4942 /* Build the block for s /= 0. */
4943 gfc_start_block (&block
);
4944 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4945 gfc_build_addr_expr (NULL_TREE
, e
));
4946 gfc_add_expr_to_block (&block
, tmp
);
4948 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4950 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4951 integer_type_node
, tmp
, emin
));
4953 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4954 build_real_from_int_cst (type
, integer_one_node
), e
);
4955 gfc_add_modify (&block
, res
, tmp
);
4957 /* Finish by building the IF statement. */
4958 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4959 build_real_from_int_cst (type
, integer_zero_node
));
4960 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4961 gfc_finish_block (&block
));
4963 gfc_add_expr_to_block (&se
->pre
, tmp
);
4968 /* RRSPACING (s) is translated into
4975 x = scalbn (x, precision - e);
4979 where precision is gfc_real_kinds[k].digits. */
4982 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4984 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4988 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4989 prec
= gfc_real_kinds
[k
].digits
;
4991 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4992 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4993 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4995 type
= gfc_typenode_for_spec (&expr
->ts
);
4996 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4997 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4999 e
= gfc_create_var (integer_type_node
, NULL
);
5000 x
= gfc_create_var (type
, NULL
);
5001 gfc_add_modify (&se
->pre
, x
,
5002 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5005 gfc_start_block (&block
);
5006 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5007 gfc_build_addr_expr (NULL_TREE
, e
));
5008 gfc_add_expr_to_block (&block
, tmp
);
5010 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5011 build_int_cst (integer_type_node
, prec
), e
);
5012 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5013 gfc_add_modify (&block
, x
, tmp
);
5014 stmt
= gfc_finish_block (&block
);
5016 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5017 build_real_from_int_cst (type
, integer_zero_node
));
5018 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5019 gfc_add_expr_to_block (&se
->pre
, tmp
);
5021 se
->expr
= fold_convert (type
, x
);
5025 /* SCALE (s, i) is translated into scalbn (s, i). */
5027 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5029 tree args
[2], type
, scalbn
;
5031 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5033 type
= gfc_typenode_for_spec (&expr
->ts
);
5034 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5035 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5036 fold_convert (type
, args
[0]),
5037 fold_convert (integer_type_node
, args
[1]));
5038 se
->expr
= fold_convert (type
, se
->expr
);
5042 /* SET_EXPONENT (s, i) is translated into
5043 scalbn (frexp (s, &dummy_int), i). */
5045 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5047 tree args
[2], type
, tmp
, frexp
, scalbn
;
5049 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5050 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5052 type
= gfc_typenode_for_spec (&expr
->ts
);
5053 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5055 tmp
= gfc_create_var (integer_type_node
, NULL
);
5056 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5057 fold_convert (type
, args
[0]),
5058 gfc_build_addr_expr (NULL_TREE
, tmp
));
5059 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5060 fold_convert (integer_type_node
, args
[1]));
5061 se
->expr
= fold_convert (type
, se
->expr
);
5066 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5068 gfc_actual_arglist
*actual
;
5075 gfc_init_se (&argse
, NULL
);
5076 actual
= expr
->value
.function
.actual
;
5078 if (actual
->expr
->ts
.type
== BT_CLASS
)
5079 gfc_add_class_array_ref (actual
->expr
);
5081 argse
.want_pointer
= 1;
5082 argse
.data_not_needed
= 1;
5083 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5084 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5085 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5086 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5088 /* Build the call to size0. */
5089 fncall0
= build_call_expr_loc (input_location
,
5090 gfor_fndecl_size0
, 1, arg1
);
5092 actual
= actual
->next
;
5096 gfc_init_se (&argse
, NULL
);
5097 gfc_conv_expr_type (&argse
, actual
->expr
,
5098 gfc_array_index_type
);
5099 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5101 /* Unusually, for an intrinsic, size does not exclude
5102 an optional arg2, so we must test for it. */
5103 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5104 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5105 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5108 /* Build the call to size1. */
5109 fncall1
= build_call_expr_loc (input_location
,
5110 gfor_fndecl_size1
, 2,
5113 gfc_init_se (&argse
, NULL
);
5114 argse
.want_pointer
= 1;
5115 argse
.data_not_needed
= 1;
5116 gfc_conv_expr (&argse
, actual
->expr
);
5117 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5118 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5119 argse
.expr
, null_pointer_node
);
5120 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5121 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5122 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5126 se
->expr
= NULL_TREE
;
5127 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5128 gfc_array_index_type
,
5129 argse
.expr
, gfc_index_one_node
);
5132 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5134 argse
.expr
= gfc_index_zero_node
;
5135 se
->expr
= NULL_TREE
;
5140 if (se
->expr
== NULL_TREE
)
5142 tree ubound
, lbound
;
5144 arg1
= build_fold_indirect_ref_loc (input_location
,
5146 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5147 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5148 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5149 gfc_array_index_type
, ubound
, lbound
);
5150 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5151 gfc_array_index_type
,
5152 se
->expr
, gfc_index_one_node
);
5153 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5154 gfc_array_index_type
, se
->expr
,
5155 gfc_index_zero_node
);
5158 type
= gfc_typenode_for_spec (&expr
->ts
);
5159 se
->expr
= convert (type
, se
->expr
);
5163 /* Helper function to compute the size of a character variable,
5164 excluding the terminating null characters. The result has
5165 gfc_array_index_type type. */
5168 size_of_string_in_bytes (int kind
, tree string_length
)
5171 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5173 bytesize
= build_int_cst (gfc_array_index_type
,
5174 gfc_character_kinds
[i
].bit_size
/ 8);
5176 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5178 fold_convert (gfc_array_index_type
, string_length
));
5183 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5194 arg
= expr
->value
.function
.actual
->expr
;
5196 gfc_init_se (&argse
, NULL
);
5200 if (arg
->ts
.type
== BT_CLASS
)
5201 gfc_add_data_component (arg
);
5203 gfc_conv_expr_reference (&argse
, arg
);
5205 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5208 /* Obtain the source word length. */
5209 if (arg
->ts
.type
== BT_CHARACTER
)
5210 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5211 argse
.string_length
);
5213 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5217 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5218 argse
.want_pointer
= 0;
5219 gfc_conv_expr_descriptor (&argse
, arg
);
5220 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5222 /* Obtain the argument's word length. */
5223 if (arg
->ts
.type
== BT_CHARACTER
)
5224 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5226 tmp
= fold_convert (gfc_array_index_type
,
5227 size_in_bytes (type
));
5228 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5230 /* Obtain the size of the array in bytes. */
5231 for (n
= 0; n
< arg
->rank
; n
++)
5234 idx
= gfc_rank_cst
[n
];
5235 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5236 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5237 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5238 gfc_array_index_type
, upper
, lower
);
5239 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5240 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5241 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5242 gfc_array_index_type
, tmp
, source_bytes
);
5243 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5245 se
->expr
= source_bytes
;
5248 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5253 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5257 tree type
, result_type
, tmp
;
5259 arg
= expr
->value
.function
.actual
->expr
;
5261 gfc_init_se (&argse
, NULL
);
5262 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5266 if (arg
->ts
.type
== BT_CLASS
)
5268 gfc_add_vptr_component (arg
);
5269 gfc_add_size_component (arg
);
5270 gfc_conv_expr (&argse
, arg
);
5271 tmp
= fold_convert (result_type
, argse
.expr
);
5275 gfc_conv_expr_reference (&argse
, arg
);
5276 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5281 argse
.want_pointer
= 0;
5282 gfc_conv_expr_descriptor (&argse
, arg
);
5283 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5286 /* Obtain the argument's word length. */
5287 if (arg
->ts
.type
== BT_CHARACTER
)
5288 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5290 tmp
= size_in_bytes (type
);
5291 tmp
= fold_convert (result_type
, tmp
);
5294 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5295 build_int_cst (result_type
, BITS_PER_UNIT
));
5296 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5300 /* Intrinsic string comparison functions. */
5303 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5307 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5310 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5311 expr
->value
.function
.actual
->expr
->ts
.kind
,
5313 se
->expr
= fold_build2_loc (input_location
, op
,
5314 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5315 build_int_cst (TREE_TYPE (se
->expr
), 0));
5318 /* Generate a call to the adjustl/adjustr library function. */
5320 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5328 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5331 type
= TREE_TYPE (args
[2]);
5332 var
= gfc_conv_string_tmp (se
, type
, len
);
5335 tmp
= build_call_expr_loc (input_location
,
5336 fndecl
, 3, args
[0], args
[1], args
[2]);
5337 gfc_add_expr_to_block (&se
->pre
, tmp
);
5339 se
->string_length
= len
;
5343 /* Generate code for the TRANSFER intrinsic:
5345 DEST = TRANSFER (SOURCE, MOLD)
5347 typeof<DEST> = typeof<MOLD>
5352 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5354 typeof<DEST> = typeof<MOLD>
5356 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5357 sizeof (DEST(0) * SIZE). */
5359 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5375 gfc_actual_arglist
*arg
;
5377 gfc_array_info
*info
;
5381 gfc_expr
*source_expr
, *mold_expr
;
5385 info
= &se
->ss
->info
->data
.array
;
5387 /* Convert SOURCE. The output from this stage is:-
5388 source_bytes = length of the source in bytes
5389 source = pointer to the source data. */
5390 arg
= expr
->value
.function
.actual
;
5391 source_expr
= arg
->expr
;
5393 /* Ensure double transfer through LOGICAL preserves all
5395 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5396 && arg
->expr
->value
.function
.esym
== NULL
5397 && arg
->expr
->value
.function
.isym
!= NULL
5398 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5399 && arg
->expr
->ts
.type
== BT_LOGICAL
5400 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5401 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5403 gfc_init_se (&argse
, NULL
);
5405 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5407 /* Obtain the pointer to source and the length of source in bytes. */
5408 if (arg
->expr
->rank
== 0)
5410 gfc_conv_expr_reference (&argse
, arg
->expr
);
5411 if (arg
->expr
->ts
.type
== BT_CLASS
)
5412 source
= gfc_class_data_get (argse
.expr
);
5414 source
= argse
.expr
;
5416 /* Obtain the source word length. */
5417 switch (arg
->expr
->ts
.type
)
5420 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5421 argse
.string_length
);
5424 tmp
= gfc_vtable_size_get (argse
.expr
);
5427 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5429 tmp
= fold_convert (gfc_array_index_type
,
5430 size_in_bytes (source_type
));
5436 argse
.want_pointer
= 0;
5437 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5438 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5439 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5441 /* Repack the source if not simply contiguous. */
5442 if (!gfc_is_simply_contiguous (arg
->expr
, false))
5444 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5446 if (gfc_option
.warn_array_temp
)
5447 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5449 source
= build_call_expr_loc (input_location
,
5450 gfor_fndecl_in_pack
, 1, tmp
);
5451 source
= gfc_evaluate_now (source
, &argse
.pre
);
5453 /* Free the temporary. */
5454 gfc_start_block (&block
);
5455 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5456 gfc_add_expr_to_block (&block
, tmp
);
5457 stmt
= gfc_finish_block (&block
);
5459 /* Clean up if it was repacked. */
5460 gfc_init_block (&block
);
5461 tmp
= gfc_conv_array_data (argse
.expr
);
5462 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5464 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5465 build_empty_stmt (input_location
));
5466 gfc_add_expr_to_block (&block
, tmp
);
5467 gfc_add_block_to_block (&block
, &se
->post
);
5468 gfc_init_block (&se
->post
);
5469 gfc_add_block_to_block (&se
->post
, &block
);
5472 /* Obtain the source word length. */
5473 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5474 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5475 argse
.string_length
);
5477 tmp
= fold_convert (gfc_array_index_type
,
5478 size_in_bytes (source_type
));
5480 /* Obtain the size of the array in bytes. */
5481 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5482 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5485 idx
= gfc_rank_cst
[n
];
5486 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5487 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5488 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5489 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5490 gfc_array_index_type
, upper
, lower
);
5491 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5492 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5493 gfc_array_index_type
, extent
,
5494 gfc_index_one_node
);
5495 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5496 gfc_array_index_type
, tmp
, source_bytes
);
5500 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5501 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5502 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5504 /* Now convert MOLD. The outputs are:
5505 mold_type = the TREE type of MOLD
5506 dest_word_len = destination word length in bytes. */
5508 mold_expr
= arg
->expr
;
5510 gfc_init_se (&argse
, NULL
);
5512 scalar_mold
= arg
->expr
->rank
== 0;
5514 if (arg
->expr
->rank
== 0)
5516 gfc_conv_expr_reference (&argse
, arg
->expr
);
5517 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5522 gfc_init_se (&argse
, NULL
);
5523 argse
.want_pointer
= 0;
5524 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5525 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5528 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5529 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5531 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5533 /* If this TRANSFER is nested in another TRANSFER, use a type
5534 that preserves all bits. */
5535 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5536 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5539 /* Obtain the destination word length. */
5540 switch (arg
->expr
->ts
.type
)
5543 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5544 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5547 tmp
= gfc_vtable_size_get (argse
.expr
);
5550 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
5553 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5554 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5556 /* Finally convert SIZE, if it is present. */
5558 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5562 gfc_init_se (&argse
, NULL
);
5563 gfc_conv_expr_reference (&argse
, arg
->expr
);
5564 tmp
= convert (gfc_array_index_type
,
5565 build_fold_indirect_ref_loc (input_location
,
5567 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5568 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5573 /* Separate array and scalar results. */
5574 if (scalar_mold
&& tmp
== NULL_TREE
)
5575 goto scalar_transfer
;
5577 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5578 if (tmp
!= NULL_TREE
)
5579 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5580 tmp
, dest_word_len
);
5584 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5585 gfc_add_modify (&se
->pre
, size_words
,
5586 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5587 gfc_array_index_type
,
5588 size_bytes
, dest_word_len
));
5590 /* Evaluate the bounds of the result. If the loop range exists, we have
5591 to check if it is too large. If so, we modify loop->to be consistent
5592 with min(size, size(source)). Otherwise, size is made consistent with
5593 the loop range, so that the right number of bytes is transferred.*/
5594 n
= se
->loop
->order
[0];
5595 if (se
->loop
->to
[n
] != NULL_TREE
)
5597 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5598 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5599 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5600 tmp
, gfc_index_one_node
);
5601 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5603 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5604 gfc_add_modify (&se
->pre
, size_bytes
,
5605 fold_build2_loc (input_location
, MULT_EXPR
,
5606 gfc_array_index_type
,
5607 size_words
, dest_word_len
));
5608 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5609 size_words
, se
->loop
->from
[n
]);
5610 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5611 upper
, gfc_index_one_node
);
5615 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5616 size_words
, gfc_index_one_node
);
5617 se
->loop
->from
[n
] = gfc_index_zero_node
;
5620 se
->loop
->to
[n
] = upper
;
5622 /* Build a destination descriptor, using the pointer, source, as the
5624 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5625 NULL_TREE
, false, true, false, &expr
->where
);
5627 /* Cast the pointer to the result. */
5628 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5629 tmp
= fold_convert (pvoid_type_node
, tmp
);
5631 /* Use memcpy to do the transfer. */
5633 = build_call_expr_loc (input_location
,
5634 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
5635 fold_convert (pvoid_type_node
, source
),
5636 fold_convert (size_type_node
,
5637 fold_build2_loc (input_location
,
5639 gfc_array_index_type
,
5642 gfc_add_expr_to_block (&se
->pre
, tmp
);
5644 se
->expr
= info
->descriptor
;
5645 if (expr
->ts
.type
== BT_CHARACTER
)
5646 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5650 /* Deal with scalar results. */
5652 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5653 dest_word_len
, source_bytes
);
5654 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5655 extent
, gfc_index_zero_node
);
5657 if (expr
->ts
.type
== BT_CHARACTER
)
5659 tree direct
, indirect
, free
;
5661 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5662 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5665 /* If source is longer than the destination, use a pointer to
5666 the source directly. */
5667 gfc_init_block (&block
);
5668 gfc_add_modify (&block
, tmpdecl
, ptr
);
5669 direct
= gfc_finish_block (&block
);
5671 /* Otherwise, allocate a string with the length of the destination
5672 and copy the source into it. */
5673 gfc_init_block (&block
);
5674 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5675 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5676 gfc_add_modify (&block
, tmpdecl
,
5677 fold_convert (TREE_TYPE (ptr
), tmp
));
5678 tmp
= build_call_expr_loc (input_location
,
5679 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5680 fold_convert (pvoid_type_node
, tmpdecl
),
5681 fold_convert (pvoid_type_node
, ptr
),
5682 fold_convert (size_type_node
, extent
));
5683 gfc_add_expr_to_block (&block
, tmp
);
5684 indirect
= gfc_finish_block (&block
);
5686 /* Wrap it up with the condition. */
5687 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5688 dest_word_len
, source_bytes
);
5689 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5690 gfc_add_expr_to_block (&se
->pre
, tmp
);
5692 /* Free the temporary string, if necessary. */
5693 free
= gfc_call_free (tmpdecl
);
5694 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5695 dest_word_len
, source_bytes
);
5696 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
5697 gfc_add_expr_to_block (&se
->post
, tmp
);
5700 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5704 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5706 ptr
= convert (build_pointer_type (mold_type
), source
);
5708 /* For CLASS results, allocate the needed memory first. */
5709 if (mold_expr
->ts
.type
== BT_CLASS
)
5712 cdata
= gfc_class_data_get (tmpdecl
);
5713 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
5714 gfc_add_modify (&se
->pre
, cdata
, tmp
);
5717 /* Use memcpy to do the transfer. */
5718 if (mold_expr
->ts
.type
== BT_CLASS
)
5719 tmp
= gfc_class_data_get (tmpdecl
);
5721 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5723 tmp
= build_call_expr_loc (input_location
,
5724 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5725 fold_convert (pvoid_type_node
, tmp
),
5726 fold_convert (pvoid_type_node
, ptr
),
5727 fold_convert (size_type_node
, extent
));
5728 gfc_add_expr_to_block (&se
->pre
, tmp
);
5730 /* For CLASS results, set the _vptr. */
5731 if (mold_expr
->ts
.type
== BT_CLASS
)
5735 vptr
= gfc_class_vptr_get (tmpdecl
);
5736 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
5738 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
5739 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
5747 /* Generate code for the ALLOCATED intrinsic.
5748 Generate inline code that directly check the address of the argument. */
5751 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5753 gfc_actual_arglist
*arg1
;
5757 gfc_init_se (&arg1se
, NULL
);
5758 arg1
= expr
->value
.function
.actual
;
5760 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5762 /* Make sure that class array expressions have both a _data
5763 component reference and an array reference.... */
5764 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5765 gfc_add_class_array_ref (arg1
->expr
);
5766 /* .... whilst scalars only need the _data component. */
5768 gfc_add_data_component (arg1
->expr
);
5771 if (arg1
->expr
->rank
== 0)
5773 /* Allocatable scalar. */
5774 arg1se
.want_pointer
= 1;
5775 gfc_conv_expr (&arg1se
, arg1
->expr
);
5780 /* Allocatable array. */
5781 arg1se
.descriptor_only
= 1;
5782 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5783 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5786 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5787 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5788 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5792 /* Generate code for the ASSOCIATED intrinsic.
5793 If both POINTER and TARGET are arrays, generate a call to library function
5794 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5795 In other cases, generate inline code that directly compare the address of
5796 POINTER with the address of TARGET. */
5799 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5801 gfc_actual_arglist
*arg1
;
5802 gfc_actual_arglist
*arg2
;
5807 tree nonzero_charlen
;
5808 tree nonzero_arraylen
;
5812 gfc_init_se (&arg1se
, NULL
);
5813 gfc_init_se (&arg2se
, NULL
);
5814 arg1
= expr
->value
.function
.actual
;
5817 /* Check whether the expression is a scalar or not; we cannot use
5818 arg1->expr->rank as it can be nonzero for proc pointers. */
5819 ss
= gfc_walk_expr (arg1
->expr
);
5820 scalar
= ss
== gfc_ss_terminator
;
5822 gfc_free_ss_chain (ss
);
5826 /* No optional target. */
5829 /* A pointer to a scalar. */
5830 arg1se
.want_pointer
= 1;
5831 gfc_conv_expr (&arg1se
, arg1
->expr
);
5832 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5833 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5834 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5836 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5837 tmp2
= gfc_class_data_get (arg1se
.expr
);
5843 /* A pointer to an array. */
5844 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5845 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5847 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5848 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5849 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5850 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5855 /* An optional target. */
5856 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5857 gfc_add_data_component (arg2
->expr
);
5859 nonzero_charlen
= NULL_TREE
;
5860 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5861 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5863 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5867 /* A pointer to a scalar. */
5868 arg1se
.want_pointer
= 1;
5869 gfc_conv_expr (&arg1se
, arg1
->expr
);
5870 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5871 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5872 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5874 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5875 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
5877 arg2se
.want_pointer
= 1;
5878 gfc_conv_expr (&arg2se
, arg2
->expr
);
5879 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5880 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
5881 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
5883 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5884 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5885 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5886 arg1se
.expr
, arg2se
.expr
);
5887 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5888 arg1se
.expr
, null_pointer_node
);
5889 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5890 boolean_type_node
, tmp
, tmp2
);
5894 /* An array pointer of zero length is not associated if target is
5896 arg1se
.descriptor_only
= 1;
5897 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5898 if (arg1
->expr
->rank
== -1)
5900 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
5901 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5902 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
5905 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
5906 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
5907 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5908 boolean_type_node
, tmp
,
5909 build_int_cst (TREE_TYPE (tmp
), 0));
5911 /* A pointer to an array, call library function _gfor_associated. */
5912 arg1se
.want_pointer
= 1;
5913 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5915 arg2se
.want_pointer
= 1;
5916 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
5917 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5918 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5919 se
->expr
= build_call_expr_loc (input_location
,
5920 gfor_fndecl_associated
, 2,
5921 arg1se
.expr
, arg2se
.expr
);
5922 se
->expr
= convert (boolean_type_node
, se
->expr
);
5923 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5924 boolean_type_node
, se
->expr
,
5928 /* If target is present zero character length pointers cannot
5930 if (nonzero_charlen
!= NULL_TREE
)
5931 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5933 se
->expr
, nonzero_charlen
);
5936 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5940 /* Generate code for the SAME_TYPE_AS intrinsic.
5941 Generate inline code that directly checks the vindices. */
5944 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5949 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
5951 gfc_init_se (&se1
, NULL
);
5952 gfc_init_se (&se2
, NULL
);
5954 a
= expr
->value
.function
.actual
->expr
;
5955 b
= expr
->value
.function
.actual
->next
->expr
;
5957 if (UNLIMITED_POLY (a
))
5959 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
5960 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5961 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5964 if (UNLIMITED_POLY (b
))
5966 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
5967 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5968 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5971 if (a
->ts
.type
== BT_CLASS
)
5973 gfc_add_vptr_component (a
);
5974 gfc_add_hash_component (a
);
5976 else if (a
->ts
.type
== BT_DERIVED
)
5977 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5978 a
->ts
.u
.derived
->hash_value
);
5980 if (b
->ts
.type
== BT_CLASS
)
5982 gfc_add_vptr_component (b
);
5983 gfc_add_hash_component (b
);
5985 else if (b
->ts
.type
== BT_DERIVED
)
5986 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5987 b
->ts
.u
.derived
->hash_value
);
5989 gfc_conv_expr (&se1
, a
);
5990 gfc_conv_expr (&se2
, b
);
5992 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5993 boolean_type_node
, se1
.expr
,
5994 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5997 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5998 boolean_type_node
, conda
, tmp
);
6001 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6002 boolean_type_node
, condb
, tmp
);
6004 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6008 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6011 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6015 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6016 se
->expr
= build_call_expr_loc (input_location
,
6017 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6018 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6022 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6025 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6029 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6031 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6032 type
= gfc_get_int_type (4);
6033 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6035 /* Convert it to the required type. */
6036 type
= gfc_typenode_for_spec (&expr
->ts
);
6037 se
->expr
= build_call_expr_loc (input_location
,
6038 gfor_fndecl_si_kind
, 1, arg
);
6039 se
->expr
= fold_convert (type
, se
->expr
);
6043 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6046 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6048 gfc_actual_arglist
*actual
;
6051 vec
<tree
, va_gc
> *args
= NULL
;
6053 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6055 gfc_init_se (&argse
, se
);
6057 /* Pass a NULL pointer for an absent arg. */
6058 if (actual
->expr
== NULL
)
6059 argse
.expr
= null_pointer_node
;
6065 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6067 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6068 ts
.type
= BT_INTEGER
;
6069 ts
.kind
= gfc_c_int_kind
;
6070 gfc_convert_type (actual
->expr
, &ts
, 2);
6072 gfc_conv_expr_reference (&argse
, actual
->expr
);
6075 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6076 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6077 vec_safe_push (args
, argse
.expr
);
6080 /* Convert it to the required type. */
6081 type
= gfc_typenode_for_spec (&expr
->ts
);
6082 se
->expr
= build_call_expr_loc_vec (input_location
,
6083 gfor_fndecl_sr_kind
, args
);
6084 se
->expr
= fold_convert (type
, se
->expr
);
6088 /* Generate code for TRIM (A) intrinsic function. */
6091 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6101 unsigned int num_args
;
6103 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6104 args
= XALLOCAVEC (tree
, num_args
);
6106 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6107 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6108 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6110 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6111 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6114 if (expr
->ts
.kind
== 1)
6115 function
= gfor_fndecl_string_trim
;
6116 else if (expr
->ts
.kind
== 4)
6117 function
= gfor_fndecl_string_trim_char4
;
6121 fndecl
= build_addr (function
, current_function_decl
);
6122 tmp
= build_call_array_loc (input_location
,
6123 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6125 gfc_add_expr_to_block (&se
->pre
, tmp
);
6127 /* Free the temporary afterwards, if necessary. */
6128 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6129 len
, build_int_cst (TREE_TYPE (len
), 0));
6130 tmp
= gfc_call_free (var
);
6131 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6132 gfc_add_expr_to_block (&se
->post
, tmp
);
6135 se
->string_length
= len
;
6139 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6142 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6144 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6145 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6147 stmtblock_t block
, body
;
6150 /* We store in charsize the size of a character. */
6151 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6152 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6154 /* Get the arguments. */
6155 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6156 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6158 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6159 ncopies_type
= TREE_TYPE (ncopies
);
6161 /* Check that NCOPIES is not negative. */
6162 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6163 build_int_cst (ncopies_type
, 0));
6164 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6165 "Argument NCOPIES of REPEAT intrinsic is negative "
6166 "(its value is %ld)",
6167 fold_convert (long_integer_type_node
, ncopies
));
6169 /* If the source length is zero, any non negative value of NCOPIES
6170 is valid, and nothing happens. */
6171 n
= gfc_create_var (ncopies_type
, "ncopies");
6172 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6173 build_int_cst (size_type_node
, 0));
6174 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6175 build_int_cst (ncopies_type
, 0), ncopies
);
6176 gfc_add_modify (&se
->pre
, n
, tmp
);
6179 /* Check that ncopies is not too large: ncopies should be less than
6180 (or equal to) MAX / slen, where MAX is the maximal integer of
6181 the gfc_charlen_type_node type. If slen == 0, we need a special
6182 case to avoid the division by zero. */
6183 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6184 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6185 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6186 fold_convert (size_type_node
, max
), slen
);
6187 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6188 ? size_type_node
: ncopies_type
;
6189 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6190 fold_convert (largest
, ncopies
),
6191 fold_convert (largest
, max
));
6192 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6193 build_int_cst (size_type_node
, 0));
6194 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6195 boolean_false_node
, cond
);
6196 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6197 "Argument NCOPIES of REPEAT intrinsic is too large");
6199 /* Compute the destination length. */
6200 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6201 fold_convert (gfc_charlen_type_node
, slen
),
6202 fold_convert (gfc_charlen_type_node
, ncopies
));
6203 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6204 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6206 /* Generate the code to do the repeat operation:
6207 for (i = 0; i < ncopies; i++)
6208 memmove (dest + (i * slen * size), src, slen*size); */
6209 gfc_start_block (&block
);
6210 count
= gfc_create_var (ncopies_type
, "count");
6211 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6212 exit_label
= gfc_build_label_decl (NULL_TREE
);
6214 /* Start the loop body. */
6215 gfc_start_block (&body
);
6217 /* Exit the loop if count >= ncopies. */
6218 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6220 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6221 TREE_USED (exit_label
) = 1;
6222 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6223 build_empty_stmt (input_location
));
6224 gfc_add_expr_to_block (&body
, tmp
);
6226 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6227 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6228 fold_convert (gfc_charlen_type_node
, slen
),
6229 fold_convert (gfc_charlen_type_node
, count
));
6230 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6231 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6232 tmp
= fold_build_pointer_plus_loc (input_location
,
6233 fold_convert (pvoid_type_node
, dest
), tmp
);
6234 tmp
= build_call_expr_loc (input_location
,
6235 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6237 fold_build2_loc (input_location
, MULT_EXPR
,
6238 size_type_node
, slen
,
6239 fold_convert (size_type_node
,
6241 gfc_add_expr_to_block (&body
, tmp
);
6243 /* Increment count. */
6244 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6245 count
, build_int_cst (TREE_TYPE (count
), 1));
6246 gfc_add_modify (&body
, count
, tmp
);
6248 /* Build the loop. */
6249 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6250 gfc_add_expr_to_block (&block
, tmp
);
6252 /* Add the exit label. */
6253 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6254 gfc_add_expr_to_block (&block
, tmp
);
6256 /* Finish the block. */
6257 tmp
= gfc_finish_block (&block
);
6258 gfc_add_expr_to_block (&se
->pre
, tmp
);
6260 /* Set the result value. */
6262 se
->string_length
= dlen
;
6266 /* Generate code for the IARGC intrinsic. */
6269 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6275 /* Call the library function. This always returns an INTEGER(4). */
6276 fndecl
= gfor_fndecl_iargc
;
6277 tmp
= build_call_expr_loc (input_location
,
6280 /* Convert it to the required type. */
6281 type
= gfc_typenode_for_spec (&expr
->ts
);
6282 tmp
= fold_convert (type
, tmp
);
6288 /* The loc intrinsic returns the address of its argument as
6289 gfc_index_integer_kind integer. */
6292 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6297 gcc_assert (!se
->ss
);
6299 arg_expr
= expr
->value
.function
.actual
->expr
;
6300 if (arg_expr
->rank
== 0)
6301 gfc_conv_expr_reference (se
, arg_expr
);
6303 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
6304 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6306 /* Create a temporary variable for loc return value. Without this,
6307 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6308 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6309 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6310 se
->expr
= temp_var
;
6314 /* The following routine generates code for the intrinsic
6315 functions from the ISO_C_BINDING module:
6321 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
6323 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
6325 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
6327 if (arg
->expr
->rank
== 0)
6328 gfc_conv_expr_reference (se
, arg
->expr
);
6329 else if (gfc_is_simply_contiguous (arg
->expr
, false))
6330 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
6333 gfc_conv_expr_descriptor (se
, arg
->expr
);
6334 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
6337 /* TODO -- the following two lines shouldn't be necessary, but if
6338 they're removed, a bug is exposed later in the code path.
6339 This workaround was thus introduced, but will have to be
6340 removed; please see PR 35150 for details about the issue. */
6341 se
->expr
= convert (pvoid_type_node
, se
->expr
);
6342 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6344 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
6345 gfc_conv_expr_reference (se
, arg
->expr
);
6346 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
6351 /* Build the addr_expr for the first argument. The argument is
6352 already an *address* so we don't need to set want_pointer in
6354 gfc_init_se (&arg1se
, NULL
);
6355 gfc_conv_expr (&arg1se
, arg
->expr
);
6356 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6357 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6359 /* See if we were given two arguments. */
6360 if (arg
->next
->expr
== NULL
)
6361 /* Only given one arg so generate a null and do a
6362 not-equal comparison against the first arg. */
6363 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6365 fold_convert (TREE_TYPE (arg1se
.expr
),
6366 null_pointer_node
));
6372 /* Given two arguments so build the arg2se from second arg. */
6373 gfc_init_se (&arg2se
, NULL
);
6374 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
6375 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6376 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6378 /* Generate test to compare that the two args are equal. */
6379 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6380 arg1se
.expr
, arg2se
.expr
);
6381 /* Generate test to ensure that the first arg is not null. */
6382 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
6384 arg1se
.expr
, null_pointer_node
);
6386 /* Finally, the generated test must check that both arg1 is not
6387 NULL and that it is equal to the second arg. */
6388 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6390 not_null_expr
, eq_expr
);
6398 /* The following routine generates code for the intrinsic
6399 subroutines from the ISO_C_BINDING module:
6401 * C_F_PROCPOINTER. */
6404 conv_isocbinding_subroutine (gfc_code
*code
)
6411 tree desc
, dim
, tmp
, stride
, offset
;
6412 stmtblock_t body
, block
;
6414 gfc_actual_arglist
*arg
= code
->ext
.actual
;
6416 gfc_init_se (&se
, NULL
);
6417 gfc_init_se (&cptrse
, NULL
);
6418 gfc_conv_expr (&cptrse
, arg
->expr
);
6419 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
6420 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
6422 gfc_init_se (&fptrse
, NULL
);
6423 if (arg
->next
->expr
->rank
== 0)
6425 fptrse
.want_pointer
= 1;
6426 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
6427 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
6428 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
6429 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6430 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
6431 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
6433 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6434 TREE_TYPE (fptrse
.expr
),
6436 fold_convert (TREE_TYPE (fptrse
.expr
),
6438 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
6439 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6440 return gfc_finish_block (&se
.pre
);
6443 gfc_start_block (&block
);
6445 /* Get the descriptor of the Fortran pointer. */
6446 fptrse
.descriptor_only
= 1;
6447 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
6448 gfc_add_block_to_block (&block
, &fptrse
.pre
);
6451 /* Set data value, dtype, and offset. */
6452 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
6453 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
6454 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
6455 gfc_get_dtype (TREE_TYPE (desc
)));
6457 /* Start scalarization of the bounds, using the shape argument. */
6459 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
6460 gcc_assert (shape_ss
!= gfc_ss_terminator
);
6461 gfc_init_se (&shapese
, NULL
);
6463 gfc_init_loopinfo (&loop
);
6464 gfc_add_ss_to_loop (&loop
, shape_ss
);
6465 gfc_conv_ss_startstride (&loop
);
6466 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
6467 gfc_mark_ss_chain_used (shape_ss
, 1);
6469 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
6470 shapese
.ss
= shape_ss
;
6472 stride
= gfc_create_var (gfc_array_index_type
, "stride");
6473 offset
= gfc_create_var (gfc_array_index_type
, "offset");
6474 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
6475 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6478 gfc_start_scalarized_body (&loop
, &body
);
6480 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6481 loop
.loopvar
[0], loop
.from
[0]);
6483 /* Set bounds and stride. */
6484 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
6485 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
6487 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
6488 gfc_add_block_to_block (&body
, &shapese
.pre
);
6489 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
6490 gfc_add_block_to_block (&body
, &shapese
.post
);
6492 /* Calculate offset. */
6493 gfc_add_modify (&body
, offset
,
6494 fold_build2_loc (input_location
, PLUS_EXPR
,
6495 gfc_array_index_type
, offset
, stride
));
6496 /* Update stride. */
6497 gfc_add_modify (&body
, stride
,
6498 fold_build2_loc (input_location
, MULT_EXPR
,
6499 gfc_array_index_type
, stride
,
6500 fold_convert (gfc_array_index_type
,
6502 /* Finish scalarization loop. */
6503 gfc_trans_scalarizing_loops (&loop
, &body
);
6504 gfc_add_block_to_block (&block
, &loop
.pre
);
6505 gfc_add_block_to_block (&block
, &loop
.post
);
6506 gfc_add_block_to_block (&block
, &fptrse
.post
);
6507 gfc_cleanup_loop (&loop
);
6509 gfc_add_modify (&block
, offset
,
6510 fold_build1_loc (input_location
, NEGATE_EXPR
,
6511 gfc_array_index_type
, offset
));
6512 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
6514 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
6515 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6516 return gfc_finish_block (&se
.pre
);
6520 /* Generate code for an intrinsic function. Some map directly to library
6521 calls, others get special handling. In some cases the name of the function
6522 used depends on the type specifiers. */
6525 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6531 name
= &expr
->value
.function
.name
[2];
6535 lib
= gfc_is_intrinsic_libcall (expr
);
6539 se
->ignore_optional
= 1;
6541 switch (expr
->value
.function
.isym
->id
)
6543 case GFC_ISYM_EOSHIFT
:
6545 case GFC_ISYM_RESHAPE
:
6546 /* For all of those the first argument specifies the type and the
6547 third is optional. */
6548 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6552 gfc_conv_intrinsic_funcall (se
, expr
);
6560 switch (expr
->value
.function
.isym
->id
)
6565 case GFC_ISYM_REPEAT
:
6566 gfc_conv_intrinsic_repeat (se
, expr
);
6570 gfc_conv_intrinsic_trim (se
, expr
);
6573 case GFC_ISYM_SC_KIND
:
6574 gfc_conv_intrinsic_sc_kind (se
, expr
);
6577 case GFC_ISYM_SI_KIND
:
6578 gfc_conv_intrinsic_si_kind (se
, expr
);
6581 case GFC_ISYM_SR_KIND
:
6582 gfc_conv_intrinsic_sr_kind (se
, expr
);
6585 case GFC_ISYM_EXPONENT
:
6586 gfc_conv_intrinsic_exponent (se
, expr
);
6590 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6592 fndecl
= gfor_fndecl_string_scan
;
6594 fndecl
= gfor_fndecl_string_scan_char4
;
6598 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6601 case GFC_ISYM_VERIFY
:
6602 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6604 fndecl
= gfor_fndecl_string_verify
;
6606 fndecl
= gfor_fndecl_string_verify_char4
;
6610 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6613 case GFC_ISYM_ALLOCATED
:
6614 gfc_conv_allocated (se
, expr
);
6617 case GFC_ISYM_ASSOCIATED
:
6618 gfc_conv_associated(se
, expr
);
6621 case GFC_ISYM_SAME_TYPE_AS
:
6622 gfc_conv_same_type_as (se
, expr
);
6626 gfc_conv_intrinsic_abs (se
, expr
);
6629 case GFC_ISYM_ADJUSTL
:
6630 if (expr
->ts
.kind
== 1)
6631 fndecl
= gfor_fndecl_adjustl
;
6632 else if (expr
->ts
.kind
== 4)
6633 fndecl
= gfor_fndecl_adjustl_char4
;
6637 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6640 case GFC_ISYM_ADJUSTR
:
6641 if (expr
->ts
.kind
== 1)
6642 fndecl
= gfor_fndecl_adjustr
;
6643 else if (expr
->ts
.kind
== 4)
6644 fndecl
= gfor_fndecl_adjustr_char4
;
6648 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6651 case GFC_ISYM_AIMAG
:
6652 gfc_conv_intrinsic_imagpart (se
, expr
);
6656 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6660 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6663 case GFC_ISYM_ANINT
:
6664 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6668 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6672 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6675 case GFC_ISYM_BTEST
:
6676 gfc_conv_intrinsic_btest (se
, expr
);
6680 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6684 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6688 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6692 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6695 case GFC_ISYM_C_ASSOCIATED
:
6696 case GFC_ISYM_C_FUNLOC
:
6697 case GFC_ISYM_C_LOC
:
6698 conv_isocbinding_function (se
, expr
);
6701 case GFC_ISYM_ACHAR
:
6703 gfc_conv_intrinsic_char (se
, expr
);
6706 case GFC_ISYM_CONVERSION
:
6708 case GFC_ISYM_LOGICAL
:
6710 gfc_conv_intrinsic_conversion (se
, expr
);
6713 /* Integer conversions are handled separately to make sure we get the
6714 correct rounding mode. */
6719 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6723 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6726 case GFC_ISYM_CEILING
:
6727 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6730 case GFC_ISYM_FLOOR
:
6731 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6735 gfc_conv_intrinsic_mod (se
, expr
, 0);
6738 case GFC_ISYM_MODULO
:
6739 gfc_conv_intrinsic_mod (se
, expr
, 1);
6742 case GFC_ISYM_CMPLX
:
6743 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6746 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6747 gfc_conv_intrinsic_iargc (se
, expr
);
6750 case GFC_ISYM_COMPLEX
:
6751 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6754 case GFC_ISYM_CONJG
:
6755 gfc_conv_intrinsic_conjg (se
, expr
);
6758 case GFC_ISYM_COUNT
:
6759 gfc_conv_intrinsic_count (se
, expr
);
6762 case GFC_ISYM_CTIME
:
6763 gfc_conv_intrinsic_ctime (se
, expr
);
6767 gfc_conv_intrinsic_dim (se
, expr
);
6770 case GFC_ISYM_DOT_PRODUCT
:
6771 gfc_conv_intrinsic_dot_product (se
, expr
);
6774 case GFC_ISYM_DPROD
:
6775 gfc_conv_intrinsic_dprod (se
, expr
);
6778 case GFC_ISYM_DSHIFTL
:
6779 gfc_conv_intrinsic_dshift (se
, expr
, true);
6782 case GFC_ISYM_DSHIFTR
:
6783 gfc_conv_intrinsic_dshift (se
, expr
, false);
6786 case GFC_ISYM_FDATE
:
6787 gfc_conv_intrinsic_fdate (se
, expr
);
6790 case GFC_ISYM_FRACTION
:
6791 gfc_conv_intrinsic_fraction (se
, expr
);
6795 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6799 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6803 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6806 case GFC_ISYM_IBCLR
:
6807 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6810 case GFC_ISYM_IBITS
:
6811 gfc_conv_intrinsic_ibits (se
, expr
);
6814 case GFC_ISYM_IBSET
:
6815 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6818 case GFC_ISYM_IACHAR
:
6819 case GFC_ISYM_ICHAR
:
6820 /* We assume ASCII character sequence. */
6821 gfc_conv_intrinsic_ichar (se
, expr
);
6824 case GFC_ISYM_IARGC
:
6825 gfc_conv_intrinsic_iargc (se
, expr
);
6829 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6832 case GFC_ISYM_INDEX
:
6833 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6835 fndecl
= gfor_fndecl_string_index
;
6837 fndecl
= gfor_fndecl_string_index_char4
;
6841 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6845 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6848 case GFC_ISYM_IPARITY
:
6849 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6852 case GFC_ISYM_IS_IOSTAT_END
:
6853 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6856 case GFC_ISYM_IS_IOSTAT_EOR
:
6857 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6860 case GFC_ISYM_ISNAN
:
6861 gfc_conv_intrinsic_isnan (se
, expr
);
6864 case GFC_ISYM_LSHIFT
:
6865 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6868 case GFC_ISYM_RSHIFT
:
6869 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6872 case GFC_ISYM_SHIFTA
:
6873 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6876 case GFC_ISYM_SHIFTL
:
6877 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6880 case GFC_ISYM_SHIFTR
:
6881 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6884 case GFC_ISYM_ISHFT
:
6885 gfc_conv_intrinsic_ishft (se
, expr
);
6888 case GFC_ISYM_ISHFTC
:
6889 gfc_conv_intrinsic_ishftc (se
, expr
);
6892 case GFC_ISYM_LEADZ
:
6893 gfc_conv_intrinsic_leadz (se
, expr
);
6896 case GFC_ISYM_TRAILZ
:
6897 gfc_conv_intrinsic_trailz (se
, expr
);
6900 case GFC_ISYM_POPCNT
:
6901 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6904 case GFC_ISYM_POPPAR
:
6905 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6908 case GFC_ISYM_LBOUND
:
6909 gfc_conv_intrinsic_bound (se
, expr
, 0);
6912 case GFC_ISYM_LCOBOUND
:
6913 conv_intrinsic_cobound (se
, expr
);
6916 case GFC_ISYM_TRANSPOSE
:
6917 /* The scalarizer has already been set up for reversed dimension access
6918 order ; now we just get the argument value normally. */
6919 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6923 gfc_conv_intrinsic_len (se
, expr
);
6926 case GFC_ISYM_LEN_TRIM
:
6927 gfc_conv_intrinsic_len_trim (se
, expr
);
6931 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6935 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6939 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6943 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6946 case GFC_ISYM_MASKL
:
6947 gfc_conv_intrinsic_mask (se
, expr
, 1);
6950 case GFC_ISYM_MASKR
:
6951 gfc_conv_intrinsic_mask (se
, expr
, 0);
6955 if (expr
->ts
.type
== BT_CHARACTER
)
6956 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6958 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6961 case GFC_ISYM_MAXLOC
:
6962 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6965 case GFC_ISYM_MAXVAL
:
6966 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6969 case GFC_ISYM_MERGE
:
6970 gfc_conv_intrinsic_merge (se
, expr
);
6973 case GFC_ISYM_MERGE_BITS
:
6974 gfc_conv_intrinsic_merge_bits (se
, expr
);
6978 if (expr
->ts
.type
== BT_CHARACTER
)
6979 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6981 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6984 case GFC_ISYM_MINLOC
:
6985 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6988 case GFC_ISYM_MINVAL
:
6989 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6992 case GFC_ISYM_NEAREST
:
6993 gfc_conv_intrinsic_nearest (se
, expr
);
6996 case GFC_ISYM_NORM2
:
6997 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
7001 gfc_conv_intrinsic_not (se
, expr
);
7005 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7008 case GFC_ISYM_PARITY
:
7009 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
7012 case GFC_ISYM_PRESENT
:
7013 gfc_conv_intrinsic_present (se
, expr
);
7016 case GFC_ISYM_PRODUCT
:
7017 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
7021 gfc_conv_intrinsic_rank (se
, expr
);
7024 case GFC_ISYM_RRSPACING
:
7025 gfc_conv_intrinsic_rrspacing (se
, expr
);
7028 case GFC_ISYM_SET_EXPONENT
:
7029 gfc_conv_intrinsic_set_exponent (se
, expr
);
7032 case GFC_ISYM_SCALE
:
7033 gfc_conv_intrinsic_scale (se
, expr
);
7037 gfc_conv_intrinsic_sign (se
, expr
);
7041 gfc_conv_intrinsic_size (se
, expr
);
7044 case GFC_ISYM_SIZEOF
:
7045 case GFC_ISYM_C_SIZEOF
:
7046 gfc_conv_intrinsic_sizeof (se
, expr
);
7049 case GFC_ISYM_STORAGE_SIZE
:
7050 gfc_conv_intrinsic_storage_size (se
, expr
);
7053 case GFC_ISYM_SPACING
:
7054 gfc_conv_intrinsic_spacing (se
, expr
);
7057 case GFC_ISYM_STRIDE
:
7058 conv_intrinsic_stride (se
, expr
);
7062 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
7065 case GFC_ISYM_TRANSFER
:
7066 if (se
->ss
&& se
->ss
->info
->useflags
)
7067 /* Access the previously obtained result. */
7068 gfc_conv_tmp_array_ref (se
);
7070 gfc_conv_intrinsic_transfer (se
, expr
);
7073 case GFC_ISYM_TTYNAM
:
7074 gfc_conv_intrinsic_ttynam (se
, expr
);
7077 case GFC_ISYM_UBOUND
:
7078 gfc_conv_intrinsic_bound (se
, expr
, 1);
7081 case GFC_ISYM_UCOBOUND
:
7082 conv_intrinsic_cobound (se
, expr
);
7086 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7090 gfc_conv_intrinsic_loc (se
, expr
);
7093 case GFC_ISYM_THIS_IMAGE
:
7094 /* For num_images() == 1, handle as LCOBOUND. */
7095 if (expr
->value
.function
.actual
->expr
7096 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7097 conv_intrinsic_cobound (se
, expr
);
7099 trans_this_image (se
, expr
);
7102 case GFC_ISYM_IMAGE_INDEX
:
7103 trans_image_index (se
, expr
);
7106 case GFC_ISYM_NUM_IMAGES
:
7107 trans_num_images (se
);
7110 case GFC_ISYM_ACCESS
:
7111 case GFC_ISYM_CHDIR
:
7112 case GFC_ISYM_CHMOD
:
7113 case GFC_ISYM_DTIME
:
7114 case GFC_ISYM_ETIME
:
7115 case GFC_ISYM_EXTENDS_TYPE_OF
:
7117 case GFC_ISYM_FGETC
:
7120 case GFC_ISYM_FPUTC
:
7121 case GFC_ISYM_FSTAT
:
7122 case GFC_ISYM_FTELL
:
7123 case GFC_ISYM_GETCWD
:
7124 case GFC_ISYM_GETGID
:
7125 case GFC_ISYM_GETPID
:
7126 case GFC_ISYM_GETUID
:
7127 case GFC_ISYM_HOSTNM
:
7129 case GFC_ISYM_IERRNO
:
7130 case GFC_ISYM_IRAND
:
7131 case GFC_ISYM_ISATTY
:
7134 case GFC_ISYM_LSTAT
:
7135 case GFC_ISYM_MALLOC
:
7136 case GFC_ISYM_MATMUL
:
7137 case GFC_ISYM_MCLOCK
:
7138 case GFC_ISYM_MCLOCK8
:
7140 case GFC_ISYM_RENAME
:
7141 case GFC_ISYM_SECOND
:
7142 case GFC_ISYM_SECNDS
:
7143 case GFC_ISYM_SIGNAL
:
7145 case GFC_ISYM_SYMLNK
:
7146 case GFC_ISYM_SYSTEM
:
7148 case GFC_ISYM_TIME8
:
7149 case GFC_ISYM_UMASK
:
7150 case GFC_ISYM_UNLINK
:
7152 gfc_conv_intrinsic_funcall (se
, expr
);
7155 case GFC_ISYM_EOSHIFT
:
7157 case GFC_ISYM_RESHAPE
:
7158 /* For those, expr->rank should always be >0 and thus the if above the
7159 switch should have matched. */
7164 gfc_conv_intrinsic_lib_function (se
, expr
);
7171 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
7173 gfc_ss
*arg_ss
, *tmp_ss
;
7174 gfc_actual_arglist
*arg
;
7176 arg
= expr
->value
.function
.actual
;
7178 gcc_assert (arg
->expr
);
7180 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
7181 gcc_assert (arg_ss
!= gfc_ss_terminator
);
7183 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
7185 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
7186 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
7190 gcc_assert (tmp_ss
->dimen
== 2);
7192 /* We just invert dimensions. */
7193 tmp_dim
= tmp_ss
->dim
[0];
7194 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
7195 tmp_ss
->dim
[1] = tmp_dim
;
7198 /* Stop when tmp_ss points to the last valid element of the chain... */
7199 if (tmp_ss
->next
== gfc_ss_terminator
)
7203 /* ... so that we can attach the rest of the chain to it. */
7210 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
7211 This has the side effect of reversing the nested list, so there is no
7212 need to call gfc_reverse_ss on it (the given list is assumed not to be
7216 nest_loop_dimension (gfc_ss
*ss
, int dim
)
7219 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
7220 gfc_loopinfo
*new_loop
;
7222 gcc_assert (ss
!= gfc_ss_terminator
);
7224 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
7226 new_ss
= gfc_get_ss ();
7227 new_ss
->next
= prev_ss
;
7228 new_ss
->parent
= ss
;
7229 new_ss
->info
= ss
->info
;
7230 new_ss
->info
->refcount
++;
7233 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
7234 && ss
->info
->type
!= GFC_SS_REFERENCE
);
7237 new_ss
->dim
[0] = ss
->dim
[dim
];
7239 gcc_assert (dim
< ss
->dimen
);
7241 ss_dim
= --ss
->dimen
;
7242 for (i
= dim
; i
< ss_dim
; i
++)
7243 ss
->dim
[i
] = ss
->dim
[i
+ 1];
7245 ss
->dim
[ss_dim
] = 0;
7251 ss
->nested_ss
->parent
= new_ss
;
7252 new_ss
->nested_ss
= ss
->nested_ss
;
7254 ss
->nested_ss
= new_ss
;
7257 new_loop
= gfc_get_loopinfo ();
7258 gfc_init_loopinfo (new_loop
);
7260 gcc_assert (prev_ss
!= NULL
);
7261 gcc_assert (prev_ss
!= gfc_ss_terminator
);
7262 gfc_add_ss_to_loop (new_loop
, prev_ss
);
7263 return new_ss
->parent
;
7267 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
7268 is to be inlined. */
7271 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
7273 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
7274 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
7276 bool scalar_mask
= false;
7278 /* The rank of the result will be determined later. */
7279 arg1
= expr
->value
.function
.actual
;
7282 gcc_assert (arg3
!= NULL
);
7284 if (expr
->rank
== 0)
7287 tmp_ss
= gfc_ss_terminator
;
7293 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
7294 if (mask_ss
== tmp_ss
)
7300 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
7301 gcc_assert (array_ss
!= tmp_ss
);
7303 /* Odd thing: If the mask is scalar, it is used by the frontend after
7304 the array (to make an if around the nested loop). Thus it shall
7305 be after array_ss once the gfc_ss list is reversed. */
7307 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
7311 /* "Hide" the dimension on which we will sum in the first arg's scalarization
7313 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
7314 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
7322 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
7325 switch (expr
->value
.function
.isym
->id
)
7327 case GFC_ISYM_PRODUCT
:
7329 return walk_inline_intrinsic_arith (ss
, expr
);
7331 case GFC_ISYM_TRANSPOSE
:
7332 return walk_inline_intrinsic_transpose (ss
, expr
);
7341 /* This generates code to execute before entering the scalarization loop.
7342 Currently does nothing. */
7345 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7347 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7349 case GFC_ISYM_UBOUND
:
7350 case GFC_ISYM_LBOUND
:
7351 case GFC_ISYM_UCOBOUND
:
7352 case GFC_ISYM_LCOBOUND
:
7353 case GFC_ISYM_THIS_IMAGE
:
7362 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7363 are expanded into code inside the scalarization loop. */
7366 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7368 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7369 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7371 /* The two argument version returns a scalar. */
7372 if (expr
->value
.function
.actual
->next
->expr
)
7375 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7379 /* Walk an intrinsic array libcall. */
7382 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7384 gcc_assert (expr
->rank
> 0);
7385 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7389 /* Return whether the function call expression EXPR will be expanded
7390 inline by gfc_conv_intrinsic_function. */
7393 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7395 gfc_actual_arglist
*args
;
7397 if (!expr
->value
.function
.isym
)
7400 switch (expr
->value
.function
.isym
->id
)
7402 case GFC_ISYM_PRODUCT
:
7404 /* Disable inline expansion if code size matters. */
7408 args
= expr
->value
.function
.actual
;
7409 /* We need to be able to subset the SUM argument at compile-time. */
7410 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7415 case GFC_ISYM_TRANSPOSE
:
7424 /* Returns nonzero if the specified intrinsic function call maps directly to
7425 an external library call. Should only be used for functions that return
7429 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7431 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7432 gcc_assert (expr
->rank
> 0);
7434 if (gfc_inline_intrinsic_function_p (expr
))
7437 switch (expr
->value
.function
.isym
->id
)
7441 case GFC_ISYM_COUNT
:
7445 case GFC_ISYM_IPARITY
:
7446 case GFC_ISYM_MATMUL
:
7447 case GFC_ISYM_MAXLOC
:
7448 case GFC_ISYM_MAXVAL
:
7449 case GFC_ISYM_MINLOC
:
7450 case GFC_ISYM_MINVAL
:
7451 case GFC_ISYM_NORM2
:
7452 case GFC_ISYM_PARITY
:
7453 case GFC_ISYM_PRODUCT
:
7455 case GFC_ISYM_SHAPE
:
7456 case GFC_ISYM_SPREAD
:
7458 /* Ignore absent optional parameters. */
7461 case GFC_ISYM_RESHAPE
:
7462 case GFC_ISYM_CSHIFT
:
7463 case GFC_ISYM_EOSHIFT
:
7465 case GFC_ISYM_UNPACK
:
7466 /* Pass absent optional parameters. */
7474 /* Walk an intrinsic function. */
7476 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7477 gfc_intrinsic_sym
* isym
)
7481 if (isym
->elemental
)
7482 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7483 NULL
, GFC_SS_SCALAR
);
7485 if (expr
->rank
== 0)
7488 if (gfc_inline_intrinsic_function_p (expr
))
7489 return walk_inline_intrinsic_function (ss
, expr
);
7491 if (gfc_is_intrinsic_libcall (expr
))
7492 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7494 /* Special cases. */
7497 case GFC_ISYM_LBOUND
:
7498 case GFC_ISYM_LCOBOUND
:
7499 case GFC_ISYM_UBOUND
:
7500 case GFC_ISYM_UCOBOUND
:
7501 case GFC_ISYM_THIS_IMAGE
:
7502 return gfc_walk_intrinsic_bound (ss
, expr
);
7504 case GFC_ISYM_TRANSFER
:
7505 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7508 /* This probably meant someone forgot to add an intrinsic to the above
7509 list(s) when they implemented it, or something's gone horribly
7517 conv_intrinsic_atomic_def (gfc_code
*code
)
7522 gfc_init_se (&atom
, NULL
);
7523 gfc_init_se (&value
, NULL
);
7524 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7525 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7527 gfc_init_block (&block
);
7528 gfc_add_modify (&block
, atom
.expr
,
7529 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7530 return gfc_finish_block (&block
);
7535 conv_intrinsic_atomic_ref (gfc_code
*code
)
7540 gfc_init_se (&atom
, NULL
);
7541 gfc_init_se (&value
, NULL
);
7542 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7543 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7545 gfc_init_block (&block
);
7546 gfc_add_modify (&block
, value
.expr
,
7547 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7548 return gfc_finish_block (&block
);
7553 conv_intrinsic_move_alloc (gfc_code
*code
)
7556 gfc_expr
*from_expr
, *to_expr
;
7557 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7558 gfc_se from_se
, to_se
;
7562 gfc_start_block (&block
);
7564 from_expr
= code
->ext
.actual
->expr
;
7565 to_expr
= code
->ext
.actual
->next
->expr
;
7567 gfc_init_se (&from_se
, NULL
);
7568 gfc_init_se (&to_se
, NULL
);
7570 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7571 || to_expr
->ts
.type
== BT_CLASS
);
7572 coarray
= gfc_get_corank (from_expr
) != 0;
7574 if (from_expr
->rank
== 0 && !coarray
)
7576 if (from_expr
->ts
.type
!= BT_CLASS
)
7577 from_expr2
= from_expr
;
7580 from_expr2
= gfc_copy_expr (from_expr
);
7581 gfc_add_data_component (from_expr2
);
7584 if (to_expr
->ts
.type
!= BT_CLASS
)
7588 to_expr2
= gfc_copy_expr (to_expr
);
7589 gfc_add_data_component (to_expr2
);
7592 from_se
.want_pointer
= 1;
7593 to_se
.want_pointer
= 1;
7594 gfc_conv_expr (&from_se
, from_expr2
);
7595 gfc_conv_expr (&to_se
, to_expr2
);
7596 gfc_add_block_to_block (&block
, &from_se
.pre
);
7597 gfc_add_block_to_block (&block
, &to_se
.pre
);
7599 /* Deallocate "to". */
7600 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7601 to_expr
, to_expr
->ts
);
7602 gfc_add_expr_to_block (&block
, tmp
);
7604 /* Assign (_data) pointers. */
7605 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7606 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7608 /* Set "from" to NULL. */
7609 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7610 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7612 gfc_add_block_to_block (&block
, &from_se
.post
);
7613 gfc_add_block_to_block (&block
, &to_se
.post
);
7616 if (to_expr
->ts
.type
== BT_CLASS
)
7620 gfc_free_expr (to_expr2
);
7621 gfc_init_se (&to_se
, NULL
);
7622 to_se
.want_pointer
= 1;
7623 gfc_add_vptr_component (to_expr
);
7624 gfc_conv_expr (&to_se
, to_expr
);
7626 if (from_expr
->ts
.type
== BT_CLASS
)
7628 if (UNLIMITED_POLY (from_expr
))
7632 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7636 gfc_free_expr (from_expr2
);
7637 gfc_init_se (&from_se
, NULL
);
7638 from_se
.want_pointer
= 1;
7639 gfc_add_vptr_component (from_expr
);
7640 gfc_conv_expr (&from_se
, from_expr
);
7641 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7642 fold_convert (TREE_TYPE (to_se
.expr
),
7645 /* Reset _vptr component to declared type. */
7647 /* Unlimited polymorphic. */
7648 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7649 fold_convert (TREE_TYPE (from_se
.expr
),
7650 null_pointer_node
));
7653 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7654 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7655 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7660 if (from_expr
->ts
.type
!= BT_DERIVED
)
7661 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7663 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7665 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7666 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7667 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7671 return gfc_finish_block (&block
);
7674 /* Update _vptr component. */
7675 if (to_expr
->ts
.type
== BT_CLASS
)
7679 to_se
.want_pointer
= 1;
7680 to_expr2
= gfc_copy_expr (to_expr
);
7681 gfc_add_vptr_component (to_expr2
);
7682 gfc_conv_expr (&to_se
, to_expr2
);
7684 if (from_expr
->ts
.type
== BT_CLASS
)
7686 if (UNLIMITED_POLY (from_expr
))
7690 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7694 from_se
.want_pointer
= 1;
7695 from_expr2
= gfc_copy_expr (from_expr
);
7696 gfc_add_vptr_component (from_expr2
);
7697 gfc_conv_expr (&from_se
, from_expr2
);
7698 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7699 fold_convert (TREE_TYPE (to_se
.expr
),
7702 /* Reset _vptr component to declared type. */
7704 /* Unlimited polymorphic. */
7705 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7706 fold_convert (TREE_TYPE (from_se
.expr
),
7707 null_pointer_node
));
7710 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7711 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7712 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7717 if (from_expr
->ts
.type
!= BT_DERIVED
)
7718 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7720 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7722 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7723 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7724 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7727 gfc_free_expr (to_expr2
);
7728 gfc_init_se (&to_se
, NULL
);
7730 if (from_expr
->ts
.type
== BT_CLASS
)
7732 gfc_free_expr (from_expr2
);
7733 gfc_init_se (&from_se
, NULL
);
7738 /* Deallocate "to". */
7739 if (from_expr
->rank
== 0)
7741 to_se
.want_coarray
= 1;
7742 from_se
.want_coarray
= 1;
7744 gfc_conv_expr_descriptor (&to_se
, to_expr
);
7745 gfc_conv_expr_descriptor (&from_se
, from_expr
);
7747 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
7748 is an image control "statement", cf. IR F08/0040 in 12-006A. */
7749 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
7753 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
7754 NULL_TREE
, NULL_TREE
, true, to_expr
,
7756 gfc_add_expr_to_block (&block
, tmp
);
7758 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7759 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7760 boolean_type_node
, tmp
,
7761 fold_convert (TREE_TYPE (tmp
),
7762 null_pointer_node
));
7763 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7764 3, null_pointer_node
, null_pointer_node
,
7765 build_int_cst (integer_type_node
, 0));
7767 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
7768 tmp
, build_empty_stmt (input_location
));
7769 gfc_add_expr_to_block (&block
, tmp
);
7773 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7774 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
7775 NULL_TREE
, true, to_expr
, false);
7776 gfc_add_expr_to_block (&block
, tmp
);
7779 /* Move the pointer and update the array descriptor data. */
7780 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7782 /* Set "from" to NULL. */
7783 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7784 gfc_add_modify_loc (input_location
, &block
, tmp
,
7785 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7787 return gfc_finish_block (&block
);
7792 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7796 gcc_assert (code
->resolved_isym
);
7798 switch (code
->resolved_isym
->id
)
7800 case GFC_ISYM_MOVE_ALLOC
:
7801 res
= conv_intrinsic_move_alloc (code
);
7804 case GFC_ISYM_ATOMIC_DEF
:
7805 res
= conv_intrinsic_atomic_def (code
);
7808 case GFC_ISYM_ATOMIC_REF
:
7809 res
= conv_intrinsic_atomic_ref (code
);
7812 case GFC_ISYM_C_F_POINTER
:
7813 case GFC_ISYM_C_F_PROCPOINTER
:
7814 res
= conv_isocbinding_subroutine (code
);
7826 #include "gt-fortran-trans-intrinsic.h"