1 /* Intrinsic translation
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
30 #include "fold-const.h"
31 #include "stringpool.h"
32 #include "tree-nested.h"
33 #include "stor-layout.h"
35 #include "diagnostic-core.h" /* For internal_error. */
36 #include "toplev.h" /* For rest_of_decl_compilation. */
39 #include "intrinsic.h"
41 #include "trans-const.h"
42 #include "trans-types.h"
43 #include "trans-array.h"
44 #include "dependency.h" /* For CAF array alias analysis. */
45 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
46 #include "trans-stmt.h"
47 #include "tree-nested.h"
49 /* This maps Fortran intrinsic math functions to external library or GCC
51 typedef struct GTY(()) gfc_intrinsic_map_t
{
52 /* The explicit enum is required to work around inadequacies in the
53 garbage collection/gengtype parsing mechanism. */
56 /* Enum value from the "language-independent", aka C-centric, part
57 of gcc, or END_BUILTINS of no such value set. */
58 enum built_in_function float_built_in
;
59 enum built_in_function double_built_in
;
60 enum built_in_function long_double_built_in
;
61 enum built_in_function complex_float_built_in
;
62 enum built_in_function complex_double_built_in
;
63 enum built_in_function complex_long_double_built_in
;
65 /* True if the naming pattern is to prepend "c" for complex and
66 append "f" for kind=4. False if the naming pattern is to
67 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
70 /* True if a complex version of the function exists. */
71 bool complex_available
;
73 /* True if the function should be marked const. */
76 /* The base library name of this function. */
79 /* Cache decls created for the various operand types. */
91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 defines complex variants of all of the entries in mathbuiltins.def
94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
97 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
103 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
106 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
112 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
113 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
114 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
116 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
118 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
120 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
121 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
122 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
123 #include "mathbuiltins.def"
125 /* Functions in libgfortran. */
126 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
129 LIB_FUNCTION (NONE
, NULL
, false)
134 #undef DEFINE_MATH_BUILTIN
135 #undef DEFINE_MATH_BUILTIN_C
138 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
141 /* Find the correct variant of a given builtin from its argument. */
143 builtin_decl_for_precision (enum built_in_function base_built_in
,
146 enum built_in_function i
= END_BUILTINS
;
148 gfc_intrinsic_map_t
*m
;
149 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
152 if (precision
== TYPE_PRECISION (float_type_node
))
153 i
= m
->float_built_in
;
154 else if (precision
== TYPE_PRECISION (double_type_node
))
155 i
= m
->double_built_in
;
156 else if (precision
== TYPE_PRECISION (long_double_type_node
))
157 i
= m
->long_double_built_in
;
158 else if (precision
== TYPE_PRECISION (float128_type_node
))
160 /* Special treatment, because it is not exactly a built-in, but
161 a library function. */
162 return m
->real16_decl
;
165 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
170 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
173 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
175 if (gfc_real_kinds
[i
].c_float128
)
177 /* For __float128, the story is a bit different, because we return
178 a decl to a library function rather than a built-in. */
179 gfc_intrinsic_map_t
*m
;
180 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
183 return m
->real16_decl
;
186 return builtin_decl_for_precision (double_built_in
,
187 gfc_real_kinds
[i
].mode_precision
);
191 /* Evaluate the arguments to an intrinsic function. The value
192 of NARGS may be less than the actual number of arguments in EXPR
193 to allow optional "KIND" arguments that are not included in the
194 generated code to be ignored. */
197 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
198 tree
*argarray
, int nargs
)
200 gfc_actual_arglist
*actual
;
202 gfc_intrinsic_arg
*formal
;
206 formal
= expr
->value
.function
.isym
->formal
;
207 actual
= expr
->value
.function
.actual
;
209 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
210 actual
= actual
->next
,
211 formal
= formal
? formal
->next
: NULL
)
215 /* Skip omitted optional arguments. */
222 /* Evaluate the parameter. This will substitute scalarized
223 references automatically. */
224 gfc_init_se (&argse
, se
);
226 if (e
->ts
.type
== BT_CHARACTER
)
228 gfc_conv_expr (&argse
, e
);
229 gfc_conv_string_parameter (&argse
);
230 argarray
[curr_arg
++] = argse
.string_length
;
231 gcc_assert (curr_arg
< nargs
);
234 gfc_conv_expr_val (&argse
, e
);
236 /* If an optional argument is itself an optional dummy argument,
237 check its presence and substitute a null if absent. */
238 if (e
->expr_type
== EXPR_VARIABLE
239 && e
->symtree
->n
.sym
->attr
.optional
242 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
244 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
245 gfc_add_block_to_block (&se
->post
, &argse
.post
);
246 argarray
[curr_arg
] = argse
.expr
;
250 /* Count the number of actual arguments to the intrinsic function EXPR
251 including any "hidden" string length arguments. */
254 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
257 gfc_actual_arglist
*actual
;
259 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
264 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
274 /* Conversions between different types are output by the frontend as
275 intrinsic functions. We implement these directly with inline code. */
278 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
284 nargs
= gfc_intrinsic_argument_list_length (expr
);
285 args
= XALLOCAVEC (tree
, nargs
);
287 /* Evaluate all the arguments passed. Whilst we're only interested in the
288 first one here, there are other parts of the front-end that assume this
289 and will trigger an ICE if it's not the case. */
290 type
= gfc_typenode_for_spec (&expr
->ts
);
291 gcc_assert (expr
->value
.function
.actual
->expr
);
292 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
294 /* Conversion between character kinds involves a call to a library
296 if (expr
->ts
.type
== BT_CHARACTER
)
298 tree fndecl
, var
, addr
, tmp
;
300 if (expr
->ts
.kind
== 1
301 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
302 fndecl
= gfor_fndecl_convert_char4_to_char1
;
303 else if (expr
->ts
.kind
== 4
304 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
305 fndecl
= gfor_fndecl_convert_char1_to_char4
;
309 /* Create the variable storing the converted value. */
310 type
= gfc_get_pchar_type (expr
->ts
.kind
);
311 var
= gfc_create_var (type
, "str");
312 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
314 /* Call the library function that will perform the conversion. */
315 gcc_assert (nargs
>= 2);
316 tmp
= build_call_expr_loc (input_location
,
317 fndecl
, 3, addr
, args
[0], args
[1]);
318 gfc_add_expr_to_block (&se
->pre
, tmp
);
320 /* Free the temporary afterwards. */
321 tmp
= gfc_call_free (var
);
322 gfc_add_expr_to_block (&se
->post
, tmp
);
325 se
->string_length
= args
[0];
330 /* Conversion from complex to non-complex involves taking the real
331 component of the value. */
332 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
333 && expr
->ts
.type
!= BT_COMPLEX
)
337 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
338 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
342 se
->expr
= convert (type
, args
[0]);
345 /* This is needed because the gcc backend only implements
346 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
347 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
348 Similarly for CEILING. */
351 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
358 argtype
= TREE_TYPE (arg
);
359 arg
= gfc_evaluate_now (arg
, pblock
);
361 intval
= convert (type
, arg
);
362 intval
= gfc_evaluate_now (intval
, pblock
);
364 tmp
= convert (argtype
, intval
);
365 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
366 boolean_type_node
, tmp
, arg
);
368 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
369 intval
, build_int_cst (type
, 1));
370 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
375 /* Round to nearest integer, away from zero. */
378 build_round_expr (tree arg
, tree restype
)
382 int argprec
, resprec
;
384 argtype
= TREE_TYPE (arg
);
385 argprec
= TYPE_PRECISION (argtype
);
386 resprec
= TYPE_PRECISION (restype
);
388 /* Depending on the type of the result, choose the int intrinsic
389 (iround, available only as a builtin, therefore cannot use it for
390 __float128), long int intrinsic (lround family) or long long
391 intrinsic (llround). We might also need to convert the result
393 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
394 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
395 else if (resprec
<= LONG_TYPE_SIZE
)
396 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
397 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
398 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
402 return fold_convert (restype
, build_call_expr_loc (input_location
,
407 /* Convert a real to an integer using a specific rounding mode.
408 Ideally we would just build the corresponding GENERIC node,
409 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
412 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
413 enum rounding_mode op
)
418 return build_fixbound_expr (pblock
, arg
, type
, 0);
422 return build_fixbound_expr (pblock
, arg
, type
, 1);
426 return build_round_expr (arg
, type
);
430 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
439 /* Round a real value using the specified rounding mode.
440 We use a temporary integer of that same kind size as the result.
441 Values larger than those that can be represented by this kind are
442 unchanged, as they will not be accurate enough to represent the
444 huge = HUGE (KIND (a))
445 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
461 kind
= expr
->ts
.kind
;
462 nargs
= gfc_intrinsic_argument_list_length (expr
);
465 /* We have builtin functions for some cases. */
469 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
473 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
480 /* Evaluate the argument. */
481 gcc_assert (expr
->value
.function
.actual
->expr
);
482 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
484 /* Use a builtin function if one exists. */
485 if (decl
!= NULL_TREE
)
487 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
491 /* This code is probably redundant, but we'll keep it lying around just
493 type
= gfc_typenode_for_spec (&expr
->ts
);
494 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
496 /* Test if the value is too large to handle sensibly. */
497 gfc_set_model_kind (kind
);
499 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
500 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
501 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
502 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
505 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
506 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
507 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
509 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
511 itype
= gfc_get_int_type (kind
);
513 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
514 tmp
= convert (type
, tmp
);
515 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
521 /* Convert to an integer using the specified rounding mode. */
524 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
530 nargs
= gfc_intrinsic_argument_list_length (expr
);
531 args
= XALLOCAVEC (tree
, nargs
);
533 /* Evaluate the argument, we process all arguments even though we only
534 use the first one for code generation purposes. */
535 type
= gfc_typenode_for_spec (&expr
->ts
);
536 gcc_assert (expr
->value
.function
.actual
->expr
);
537 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
539 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
541 /* Conversion to a different integer kind. */
542 se
->expr
= convert (type
, args
[0]);
546 /* Conversion from complex to non-complex involves taking the real
547 component of the value. */
548 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
549 && expr
->ts
.type
!= BT_COMPLEX
)
553 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
554 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
558 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
563 /* Get the imaginary component of a value. */
566 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
570 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
571 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
572 TREE_TYPE (TREE_TYPE (arg
)), arg
);
576 /* Get the complex conjugate of a value. */
579 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
583 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
584 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
590 define_quad_builtin (const char *name
, tree type
, bool is_const
)
593 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
596 /* Mark the decl as external. */
597 DECL_EXTERNAL (fndecl
) = 1;
598 TREE_PUBLIC (fndecl
) = 1;
600 /* Mark it __attribute__((const)). */
601 TREE_READONLY (fndecl
) = is_const
;
603 rest_of_decl_compilation (fndecl
, 1, 0);
610 /* Initialize function decls for library functions. The external functions
611 are created as required. Builtin functions are added here. */
614 gfc_build_intrinsic_lib_fndecls (void)
616 gfc_intrinsic_map_t
*m
;
617 tree quad_decls
[END_BUILTINS
+ 1];
619 if (gfc_real16_is_float128
)
621 /* If we have soft-float types, we create the decls for their
622 C99-like library functions. For now, we only handle __float128
623 q-suffixed functions. */
625 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
626 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
628 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
630 type
= float128_type_node
;
631 complex_type
= complex_float128_type_node
;
632 /* type (*) (type) */
633 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
635 func_iround
= build_function_type_list (integer_type_node
,
637 /* long (*) (type) */
638 func_lround
= build_function_type_list (long_integer_type_node
,
640 /* long long (*) (type) */
641 func_llround
= build_function_type_list (long_long_integer_type_node
,
643 /* type (*) (type, type) */
644 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
645 /* type (*) (type, &int) */
647 = build_function_type_list (type
,
649 build_pointer_type (integer_type_node
),
651 /* type (*) (type, int) */
652 func_scalbn
= build_function_type_list (type
,
653 type
, integer_type_node
, NULL_TREE
);
654 /* type (*) (complex type) */
655 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
656 /* complex type (*) (complex type, complex type) */
658 = build_function_type_list (complex_type
,
659 complex_type
, complex_type
, NULL_TREE
);
661 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
662 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
663 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
665 /* Only these built-ins are actually needed here. These are used directly
666 from the code, when calling builtin_decl_for_precision() or
667 builtin_decl_for_float_type(). The others are all constructed by
668 gfc_get_intrinsic_lib_fndecl(). */
669 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
670 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
672 #include "mathbuiltins.def"
676 #undef DEFINE_MATH_BUILTIN
677 #undef DEFINE_MATH_BUILTIN_C
679 /* There is one built-in we defined manually, because it gets called
680 with builtin_decl_for_precision() or builtin_decl_for_float_type()
681 even though it is not an OTHER_BUILTIN: it is SQRT. */
682 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
686 /* Add GCC builtin functions. */
687 for (m
= gfc_intrinsic_map
;
688 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
690 if (m
->float_built_in
!= END_BUILTINS
)
691 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
692 if (m
->complex_float_built_in
!= END_BUILTINS
)
693 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
694 if (m
->double_built_in
!= END_BUILTINS
)
695 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
696 if (m
->complex_double_built_in
!= END_BUILTINS
)
697 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
699 /* If real(kind=10) exists, it is always long double. */
700 if (m
->long_double_built_in
!= END_BUILTINS
)
701 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
702 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
704 = builtin_decl_explicit (m
->complex_long_double_built_in
);
706 if (!gfc_real16_is_float128
)
708 if (m
->long_double_built_in
!= END_BUILTINS
)
709 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
710 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
712 = builtin_decl_explicit (m
->complex_long_double_built_in
);
714 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
716 /* Quad-precision function calls are constructed when first
717 needed by builtin_decl_for_precision(), except for those
718 that will be used directly (define by OTHER_BUILTIN). */
719 m
->real16_decl
= quad_decls
[m
->double_built_in
];
721 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
723 /* Same thing for the complex ones. */
724 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
730 /* Create a fndecl for a simple intrinsic library function. */
733 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
736 vec
<tree
, va_gc
> *argtypes
;
738 gfc_actual_arglist
*actual
;
741 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
744 if (ts
->type
== BT_REAL
)
749 pdecl
= &m
->real4_decl
;
752 pdecl
= &m
->real8_decl
;
755 pdecl
= &m
->real10_decl
;
758 pdecl
= &m
->real16_decl
;
764 else if (ts
->type
== BT_COMPLEX
)
766 gcc_assert (m
->complex_available
);
771 pdecl
= &m
->complex4_decl
;
774 pdecl
= &m
->complex8_decl
;
777 pdecl
= &m
->complex10_decl
;
780 pdecl
= &m
->complex16_decl
;
794 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
795 if (gfc_real_kinds
[n
].c_float
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
798 else if (gfc_real_kinds
[n
].c_double
)
799 snprintf (name
, sizeof (name
), "%s%s",
800 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
801 else if (gfc_real_kinds
[n
].c_long_double
)
802 snprintf (name
, sizeof (name
), "%s%s%s",
803 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
804 else if (gfc_real_kinds
[n
].c_float128
)
805 snprintf (name
, sizeof (name
), "%s%s%s",
806 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
812 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
813 ts
->type
== BT_COMPLEX
? 'c' : 'r',
818 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
820 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
821 vec_safe_push (argtypes
, type
);
823 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
824 fndecl
= build_decl (input_location
,
825 FUNCTION_DECL
, get_identifier (name
), type
);
827 /* Mark the decl as external. */
828 DECL_EXTERNAL (fndecl
) = 1;
829 TREE_PUBLIC (fndecl
) = 1;
831 /* Mark it __attribute__((const)), if possible. */
832 TREE_READONLY (fndecl
) = m
->is_constant
;
834 rest_of_decl_compilation (fndecl
, 1, 0);
841 /* Convert an intrinsic function into an external or builtin call. */
844 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
846 gfc_intrinsic_map_t
*m
;
850 unsigned int num_args
;
853 id
= expr
->value
.function
.isym
->id
;
854 /* Find the entry for this function. */
855 for (m
= gfc_intrinsic_map
;
856 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
862 if (m
->id
== GFC_ISYM_NONE
)
864 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
865 expr
->value
.function
.name
, id
);
868 /* Get the decl and generate the call. */
869 num_args
= gfc_intrinsic_argument_list_length (expr
);
870 args
= XALLOCAVEC (tree
, num_args
);
872 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
873 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
874 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
876 fndecl
= build_addr (fndecl
);
877 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
881 /* If bounds-checking is enabled, create code to verify at runtime that the
882 string lengths for both expressions are the same (needed for e.g. MERGE).
883 If bounds-checking is not enabled, does nothing. */
886 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
887 tree a
, tree b
, stmtblock_t
* target
)
892 /* If bounds-checking is disabled, do nothing. */
893 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
896 /* Compare the two string lengths. */
897 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
899 /* Output the runtime-check. */
900 name
= gfc_build_cstring_const (intr_name
);
901 name
= gfc_build_addr_expr (pchar_type_node
, name
);
902 gfc_trans_runtime_check (true, false, cond
, target
, where
,
903 "Unequal character lengths (%ld/%ld) in %s",
904 fold_convert (long_integer_type_node
, a
),
905 fold_convert (long_integer_type_node
, b
), name
);
909 /* The EXPONENT(X) intrinsic function is translated into
911 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
912 so that if X is a NaN or infinity, the result is HUGE(0).
916 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
918 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
921 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
922 expr
->value
.function
.actual
->expr
->ts
.kind
);
924 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
925 arg
= gfc_evaluate_now (arg
, &se
->pre
);
927 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
928 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
929 cond
= build_call_expr_loc (input_location
,
930 builtin_decl_explicit (BUILT_IN_ISFINITE
),
933 res
= gfc_create_var (integer_type_node
, NULL
);
934 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
935 gfc_build_addr_expr (NULL_TREE
, res
));
936 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
938 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
941 type
= gfc_typenode_for_spec (&expr
->ts
);
942 se
->expr
= fold_convert (type
, se
->expr
);
946 /* Fill in the following structure
947 struct caf_vector_t {
948 size_t nvec; // size of the vector
955 ptrdiff_t lower_bound;
956 ptrdiff_t upper_bound;
963 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
964 tree lower
, tree upper
, tree stride
,
965 tree vector
, int kind
, tree nvec
)
967 tree field
, type
, tmp
;
969 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
970 type
= TREE_TYPE (desc
);
972 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
973 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
974 desc
, field
, NULL_TREE
);
975 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
978 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
979 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
980 desc
, field
, NULL_TREE
);
981 type
= TREE_TYPE (desc
);
983 /* Access the inner struct. */
984 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
985 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
986 desc
, field
, NULL_TREE
);
987 type
= TREE_TYPE (desc
);
989 if (vector
!= NULL_TREE
)
991 /* Set dim.lower/upper/stride. */
992 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
993 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
994 desc
, field
, NULL_TREE
);
995 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
996 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
997 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
998 desc
, field
, NULL_TREE
);
999 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1003 /* Set vector and kind. */
1004 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1005 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1006 desc
, field
, NULL_TREE
);
1007 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1009 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1010 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1011 desc
, field
, NULL_TREE
);
1012 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1014 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1015 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1016 desc
, field
, NULL_TREE
);
1017 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1023 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1026 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1027 tree lbound
, ubound
, tmp
;
1030 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1032 for (i
= 0; i
< ar
->dimen
; i
++)
1033 switch (ar
->dimen_type
[i
])
1038 gfc_init_se (&argse
, NULL
);
1039 gfc_conv_expr (&argse
, ar
->end
[i
]);
1040 gfc_add_block_to_block (block
, &argse
.pre
);
1041 upper
= gfc_evaluate_now (argse
.expr
, block
);
1044 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1047 gfc_init_se (&argse
, NULL
);
1048 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1049 gfc_add_block_to_block (block
, &argse
.pre
);
1050 stride
= gfc_evaluate_now (argse
.expr
, block
);
1053 stride
= gfc_index_one_node
;
1059 gfc_init_se (&argse
, NULL
);
1060 gfc_conv_expr (&argse
, ar
->start
[i
]);
1061 gfc_add_block_to_block (block
, &argse
.pre
);
1062 lower
= gfc_evaluate_now (argse
.expr
, block
);
1065 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1066 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1069 stride
= gfc_index_one_node
;
1072 nvec
= size_zero_node
;
1073 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1078 gfc_init_se (&argse
, NULL
);
1079 argse
.descriptor_only
= 1;
1080 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1081 gfc_add_block_to_block (block
, &argse
.pre
);
1082 vector
= argse
.expr
;
1083 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1084 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1085 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1086 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1087 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1088 TREE_TYPE (nvec
), nvec
, tmp
);
1089 lower
= gfc_index_zero_node
;
1090 upper
= gfc_index_zero_node
;
1091 stride
= gfc_index_zero_node
;
1092 vector
= gfc_conv_descriptor_data_get (vector
);
1093 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1094 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1099 return gfc_build_addr_expr (NULL_TREE
, var
);
1103 /* Get data from a remote coarray. */
1106 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1107 tree may_require_tmp
)
1109 gfc_expr
*array_expr
;
1111 tree caf_decl
, token
, offset
, image_index
, tmp
;
1112 tree res_var
, dst_var
, type
, kind
, vec
;
1114 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1116 if (se
->ss
&& se
->ss
->info
->useflags
)
1118 /* Access the previously obtained result. */
1119 gfc_conv_tmp_array_ref (se
);
1123 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1124 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1125 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1130 vec
= null_pointer_node
;
1132 gfc_init_se (&argse
, NULL
);
1133 if (array_expr
->rank
== 0)
1135 symbol_attribute attr
;
1137 gfc_clear_attr (&attr
);
1138 gfc_conv_expr (&argse
, array_expr
);
1140 if (lhs
== NULL_TREE
)
1142 gfc_clear_attr (&attr
);
1143 if (array_expr
->ts
.type
== BT_CHARACTER
)
1144 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1145 argse
.string_length
);
1147 res_var
= gfc_create_var (type
, "caf_res");
1148 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1149 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1151 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1152 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1156 /* If has_vector, pass descriptor for whole array and the
1157 vector bounds separately. */
1158 gfc_array_ref
*ar
, ar2
;
1159 bool has_vector
= false;
1161 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1164 ar
= gfc_find_array_ref (expr
);
1166 memset (ar
, '\0', sizeof (*ar
));
1170 gfc_conv_expr_descriptor (&argse
, array_expr
);
1171 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1172 has the wrong type if component references are done. */
1173 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1174 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1179 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1183 if (lhs
== NULL_TREE
)
1185 /* Create temporary. */
1186 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1187 if (se
->loop
->to
[n
] == NULL_TREE
)
1190 gfc_conv_descriptor_lbound_get (argse
.expr
, gfc_rank_cst
[n
]);
1192 gfc_conv_descriptor_ubound_get (argse
.expr
, gfc_rank_cst
[n
]);
1194 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1195 NULL_TREE
, false, true, false,
1196 &array_expr
->where
);
1197 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1198 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1200 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1203 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1204 if (lhs_kind
== NULL_TREE
)
1207 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1208 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1210 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1211 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1212 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1213 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1214 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, argse
.expr
, array_expr
);
1216 /* No overlap possible as we have generated a temporary. */
1217 if (lhs
== NULL_TREE
)
1218 may_require_tmp
= boolean_false_node
;
1220 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 9,
1221 token
, offset
, image_index
, argse
.expr
, vec
,
1222 dst_var
, kind
, lhs_kind
, may_require_tmp
);
1223 gfc_add_expr_to_block (&se
->pre
, tmp
);
1226 gfc_advance_se_ss_chain (se
);
1229 if (array_expr
->ts
.type
== BT_CHARACTER
)
1230 se
->string_length
= argse
.string_length
;
1234 /* Send data to a remove coarray. */
1237 conv_caf_send (gfc_code
*code
) {
1238 gfc_expr
*lhs_expr
, *rhs_expr
;
1239 gfc_se lhs_se
, rhs_se
;
1241 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1242 tree may_require_tmp
;
1243 tree lhs_type
= NULL_TREE
;
1244 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1246 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1248 lhs_expr
= code
->ext
.actual
->expr
;
1249 rhs_expr
= code
->ext
.actual
->next
->expr
;
1250 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1251 ? boolean_false_node
: boolean_true_node
;
1252 gfc_init_block (&block
);
1255 gfc_init_se (&lhs_se
, NULL
);
1256 if (lhs_expr
->rank
== 0)
1258 symbol_attribute attr
;
1259 gfc_clear_attr (&attr
);
1260 gfc_conv_expr (&lhs_se
, lhs_expr
);
1261 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1262 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1263 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1267 /* If has_vector, pass descriptor for whole array and the
1268 vector bounds separately. */
1269 gfc_array_ref
*ar
, ar2
;
1270 bool has_vector
= false;
1272 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1275 ar
= gfc_find_array_ref (lhs_expr
);
1277 memset (ar
, '\0', sizeof (*ar
));
1281 lhs_se
.want_pointer
= 1;
1282 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1283 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1284 has the wrong type if component references are done. */
1285 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1286 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1287 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1288 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1293 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1298 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1299 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1301 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1302 temporary and a loop. */
1303 if (!gfc_is_coindexed (lhs_expr
))
1305 gcc_assert (gfc_is_coindexed (rhs_expr
));
1306 gfc_init_se (&rhs_se
, NULL
);
1307 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1309 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1310 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1311 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1312 return gfc_finish_block (&block
);
1315 /* Obtain token, offset and image index for the LHS. */
1317 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1318 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1319 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1320 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1321 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, lhs_se
.expr
, lhs_expr
);
1324 gfc_init_se (&rhs_se
, NULL
);
1325 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1326 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1327 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1328 if (rhs_expr
->rank
== 0)
1330 symbol_attribute attr
;
1331 gfc_clear_attr (&attr
);
1332 gfc_conv_expr (&rhs_se
, rhs_expr
);
1333 if (!gfc_is_coindexed (rhs_expr
) && rhs_expr
->ts
.type
!= BT_CHARACTER
)
1334 rhs_se
.expr
= fold_convert (lhs_type
, rhs_se
.expr
);
1335 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1336 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1340 /* If has_vector, pass descriptor for whole array and the
1341 vector bounds separately. */
1342 gfc_array_ref
*ar
, ar2
;
1343 bool has_vector
= false;
1346 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
1349 ar
= gfc_find_array_ref (rhs_expr
);
1351 memset (ar
, '\0', sizeof (*ar
));
1355 rhs_se
.want_pointer
= 1;
1356 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1357 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1358 has the wrong type if component references are done. */
1359 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1360 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1361 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1362 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1367 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
1372 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1374 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
1376 if (!gfc_is_coindexed (rhs_expr
))
1377 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 9, token
,
1378 offset
, image_index
, lhs_se
.expr
, vec
,
1379 rhs_se
.expr
, lhs_kind
, rhs_kind
, may_require_tmp
);
1382 tree rhs_token
, rhs_offset
, rhs_image_index
;
1384 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
1385 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1386 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1387 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
1388 gfc_get_caf_token_offset (&rhs_token
, &rhs_offset
, caf_decl
, rhs_se
.expr
,
1390 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
, 13,
1391 token
, offset
, image_index
, lhs_se
.expr
, vec
,
1392 rhs_token
, rhs_offset
, rhs_image_index
,
1393 rhs_se
.expr
, rhs_vec
, lhs_kind
, rhs_kind
,
1396 gfc_add_expr_to_block (&block
, tmp
);
1397 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1398 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1399 return gfc_finish_block (&block
);
1404 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1407 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1408 lbound
, ubound
, extent
, ml
;
1411 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1413 if (expr
->value
.function
.actual
->expr
1414 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1415 distance
= expr
->value
.function
.actual
->expr
;
1417 /* The case -fcoarray=single is handled elsewhere. */
1418 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
1420 /* Argument-free version: THIS_IMAGE(). */
1421 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1425 gfc_init_se (&argse
, NULL
);
1426 gfc_conv_expr_val (&argse
, distance
);
1427 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1428 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1429 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1432 tmp
= integer_zero_node
;
1433 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1435 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1440 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1442 type
= gfc_get_int_type (gfc_default_integer_kind
);
1443 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1444 rank
= expr
->value
.function
.actual
->expr
->rank
;
1446 /* Obtain the descriptor of the COARRAY. */
1447 gfc_init_se (&argse
, NULL
);
1448 argse
.want_coarray
= 1;
1449 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1450 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1451 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1456 /* Create an implicit second parameter from the loop variable. */
1457 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1458 gcc_assert (corank
> 0);
1459 gcc_assert (se
->loop
->dimen
== 1);
1460 gcc_assert (se
->ss
->info
->expr
== expr
);
1462 dim_arg
= se
->loop
->loopvar
[0];
1463 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1464 gfc_array_index_type
, dim_arg
,
1465 build_int_cst (TREE_TYPE (dim_arg
), 1));
1466 gfc_advance_se_ss_chain (se
);
1470 /* Use the passed DIM= argument. */
1471 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1472 gfc_init_se (&argse
, NULL
);
1473 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1474 gfc_array_index_type
);
1475 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1476 dim_arg
= argse
.expr
;
1478 if (INTEGER_CST_P (dim_arg
))
1480 if (wi::ltu_p (dim_arg
, 1)
1481 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1482 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1483 "dimension index", expr
->value
.function
.isym
->name
,
1486 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1488 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1489 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1491 build_int_cst (TREE_TYPE (dim_arg
), 1));
1492 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1493 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1495 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1496 boolean_type_node
, cond
, tmp
);
1497 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1502 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1503 one always has a dim_arg argument.
1505 m = this_image() - 1
1508 sub(1) = m + lcobound(corank)
1512 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1515 extent = gfc_extent(i)
1523 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1524 : m + lcobound(corank)
1527 /* this_image () - 1. */
1528 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1530 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1531 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1534 /* sub(1) = m + lcobound(corank). */
1535 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1536 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1538 lbound
= fold_convert (type
, lbound
);
1539 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1545 m
= gfc_create_var (type
, NULL
);
1546 ml
= gfc_create_var (type
, NULL
);
1547 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1548 min_var
= gfc_create_var (integer_type_node
, NULL
);
1550 /* m = this_image () - 1. */
1551 gfc_add_modify (&se
->pre
, m
, tmp
);
1553 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1554 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1555 fold_convert (integer_type_node
, dim_arg
),
1556 build_int_cst (integer_type_node
, rank
- 1));
1557 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1558 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1560 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1563 tmp
= build_int_cst (integer_type_node
, rank
);
1564 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1566 exit_label
= gfc_build_label_decl (NULL_TREE
);
1567 TREE_USED (exit_label
) = 1;
1570 gfc_init_block (&loop
);
1573 gfc_add_modify (&loop
, ml
, m
);
1576 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1577 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1578 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1579 extent
= fold_convert (type
, extent
);
1582 gfc_add_modify (&loop
, m
,
1583 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1586 /* Exit condition: if (i >= min_var) goto exit_label. */
1587 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1589 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1590 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1591 build_empty_stmt (input_location
));
1592 gfc_add_expr_to_block (&loop
, tmp
);
1594 /* Increment loop variable: i++. */
1595 gfc_add_modify (&loop
, loop_var
,
1596 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1598 build_int_cst (integer_type_node
, 1)));
1600 /* Making the loop... actually loop! */
1601 tmp
= gfc_finish_block (&loop
);
1602 tmp
= build1_v (LOOP_EXPR
, tmp
);
1603 gfc_add_expr_to_block (&se
->pre
, tmp
);
1605 /* The exit label. */
1606 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1607 gfc_add_expr_to_block (&se
->pre
, tmp
);
1609 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1610 : m + lcobound(corank) */
1612 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1613 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1615 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1616 fold_build2_loc (input_location
, PLUS_EXPR
,
1617 gfc_array_index_type
, dim_arg
,
1618 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1619 lbound
= fold_convert (type
, lbound
);
1621 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1622 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1624 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1626 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1627 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1633 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1635 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1637 gfc_se argse
, subse
;
1638 int rank
, corank
, codim
;
1640 type
= gfc_get_int_type (gfc_default_integer_kind
);
1641 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1642 rank
= expr
->value
.function
.actual
->expr
->rank
;
1644 /* Obtain the descriptor of the COARRAY. */
1645 gfc_init_se (&argse
, NULL
);
1646 argse
.want_coarray
= 1;
1647 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1648 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1649 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1652 /* Obtain a handle to the SUB argument. */
1653 gfc_init_se (&subse
, NULL
);
1654 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1655 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1656 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1657 subdesc
= build_fold_indirect_ref_loc (input_location
,
1658 gfc_conv_descriptor_data_get (subse
.expr
));
1660 /* Fortran 2008 does not require that the values remain in the cobounds,
1661 thus we need explicitly check this - and return 0 if they are exceeded. */
1663 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1664 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1665 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1666 fold_convert (gfc_array_index_type
, tmp
),
1669 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1671 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1672 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1673 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1674 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1675 fold_convert (gfc_array_index_type
, tmp
),
1677 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1678 boolean_type_node
, invalid_bound
, cond
);
1679 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1680 fold_convert (gfc_array_index_type
, tmp
),
1682 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1683 boolean_type_node
, invalid_bound
, cond
);
1686 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1688 /* See Fortran 2008, C.10 for the following algorithm. */
1690 /* coindex = sub(corank) - lcobound(n). */
1691 coindex
= fold_convert (gfc_array_index_type
,
1692 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1694 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1695 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1696 fold_convert (gfc_array_index_type
, coindex
),
1699 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1701 tree extent
, ubound
;
1703 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1704 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1705 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1706 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1708 /* coindex *= extent. */
1709 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1710 gfc_array_index_type
, coindex
, extent
);
1712 /* coindex += sub(codim). */
1713 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1714 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1715 gfc_array_index_type
, coindex
,
1716 fold_convert (gfc_array_index_type
, tmp
));
1718 /* coindex -= lbound(codim). */
1719 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1720 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1721 gfc_array_index_type
, coindex
, lbound
);
1724 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1725 fold_convert(type
, coindex
),
1726 build_int_cst (type
, 1));
1728 /* Return 0 if "coindex" exceeds num_images(). */
1730 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
1731 num_images
= build_int_cst (type
, 1);
1734 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1736 build_int_cst (integer_type_node
, -1));
1737 num_images
= fold_convert (type
, tmp
);
1740 tmp
= gfc_create_var (type
, NULL
);
1741 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1743 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1745 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1747 fold_convert (boolean_type_node
, invalid_bound
));
1748 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1749 build_int_cst (type
, 0), tmp
);
1754 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1756 tree tmp
, distance
, failed
;
1759 if (expr
->value
.function
.actual
->expr
)
1761 gfc_init_se (&argse
, NULL
);
1762 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1763 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1764 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1765 distance
= fold_convert (integer_type_node
, argse
.expr
);
1768 distance
= integer_zero_node
;
1770 if (expr
->value
.function
.actual
->next
->expr
)
1772 gfc_init_se (&argse
, NULL
);
1773 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1774 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1775 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1776 failed
= fold_convert (integer_type_node
, argse
.expr
);
1779 failed
= build_int_cst (integer_type_node
, -1);
1781 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1783 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1788 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1792 gfc_init_se (&argse
, NULL
);
1793 argse
.data_not_needed
= 1;
1794 argse
.descriptor_only
= 1;
1796 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1797 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1798 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1800 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1804 /* Evaluate a single upper or lower bound. */
1805 /* TODO: bound intrinsic generates way too much unnecessary code. */
1808 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1810 gfc_actual_arglist
*arg
;
1811 gfc_actual_arglist
*arg2
;
1816 tree cond
, cond1
, cond3
, cond4
, size
;
1820 gfc_array_spec
* as
;
1821 bool assumed_rank_lb_one
;
1823 arg
= expr
->value
.function
.actual
;
1828 /* Create an implicit second parameter from the loop variable. */
1829 gcc_assert (!arg2
->expr
);
1830 gcc_assert (se
->loop
->dimen
== 1);
1831 gcc_assert (se
->ss
->info
->expr
== expr
);
1832 gfc_advance_se_ss_chain (se
);
1833 bound
= se
->loop
->loopvar
[0];
1834 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1835 gfc_array_index_type
, bound
,
1840 /* use the passed argument. */
1841 gcc_assert (arg2
->expr
);
1842 gfc_init_se (&argse
, NULL
);
1843 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1844 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1846 /* Convert from one based to zero based. */
1847 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1848 gfc_array_index_type
, bound
,
1849 gfc_index_one_node
);
1852 /* TODO: don't re-evaluate the descriptor on each iteration. */
1853 /* Get a descriptor for the first parameter. */
1854 gfc_init_se (&argse
, NULL
);
1855 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1856 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1857 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1861 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1863 if (INTEGER_CST_P (bound
))
1865 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1866 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1867 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1868 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1869 "dimension index", upper
? "UBOUND" : "LBOUND",
1873 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1875 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1877 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1878 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1879 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1880 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1881 tmp
= gfc_conv_descriptor_rank (desc
);
1883 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1884 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1885 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1886 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1887 boolean_type_node
, cond
, tmp
);
1888 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1893 /* Take care of the lbound shift for assumed-rank arrays, which are
1894 nonallocatable and nonpointers. Those has a lbound of 1. */
1895 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1896 && ((arg
->expr
->ts
.type
!= BT_CLASS
1897 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1898 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1899 || (arg
->expr
->ts
.type
== BT_CLASS
1900 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1901 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1903 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1904 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1906 /* 13.14.53: Result value for LBOUND
1908 Case (i): For an array section or for an array expression other than a
1909 whole array or array structure component, LBOUND(ARRAY, DIM)
1910 has the value 1. For a whole array or array structure
1911 component, LBOUND(ARRAY, DIM) has the value:
1912 (a) equal to the lower bound for subscript DIM of ARRAY if
1913 dimension DIM of ARRAY does not have extent zero
1914 or if ARRAY is an assumed-size array of rank DIM,
1917 13.14.113: Result value for UBOUND
1919 Case (i): For an array section or for an array expression other than a
1920 whole array or array structure component, UBOUND(ARRAY, DIM)
1921 has the value equal to the number of elements in the given
1922 dimension; otherwise, it has a value equal to the upper bound
1923 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1924 not have size zero and has value zero if dimension DIM has
1927 if (!upper
&& assumed_rank_lb_one
)
1928 se
->expr
= gfc_index_one_node
;
1931 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1933 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1935 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1936 stride
, gfc_index_zero_node
);
1937 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1938 boolean_type_node
, cond3
, cond1
);
1939 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1940 stride
, gfc_index_zero_node
);
1945 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1946 boolean_type_node
, cond3
, cond4
);
1947 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1948 gfc_index_one_node
, lbound
);
1949 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1950 boolean_type_node
, cond4
, cond5
);
1952 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1953 boolean_type_node
, cond
, cond5
);
1955 if (assumed_rank_lb_one
)
1957 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1958 gfc_array_index_type
, ubound
, lbound
);
1959 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1960 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1965 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1966 gfc_array_index_type
, cond
,
1967 tmp
, gfc_index_zero_node
);
1971 if (as
->type
== AS_ASSUMED_SIZE
)
1972 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1973 bound
, build_int_cst (TREE_TYPE (bound
),
1974 arg
->expr
->rank
- 1));
1976 cond
= boolean_false_node
;
1978 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1979 boolean_type_node
, cond3
, cond4
);
1980 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1981 boolean_type_node
, cond
, cond1
);
1983 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1984 gfc_array_index_type
, cond
,
1985 lbound
, gfc_index_one_node
);
1992 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1993 gfc_array_index_type
, ubound
, lbound
);
1994 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1995 gfc_array_index_type
, size
,
1996 gfc_index_one_node
);
1997 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1998 gfc_array_index_type
, se
->expr
,
1999 gfc_index_zero_node
);
2002 se
->expr
= gfc_index_one_node
;
2005 type
= gfc_typenode_for_spec (&expr
->ts
);
2006 se
->expr
= convert (type
, se
->expr
);
2011 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2013 gfc_actual_arglist
*arg
;
2014 gfc_actual_arglist
*arg2
;
2016 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2020 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2021 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2022 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2024 arg
= expr
->value
.function
.actual
;
2027 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2028 corank
= gfc_get_corank (arg
->expr
);
2030 gfc_init_se (&argse
, NULL
);
2031 argse
.want_coarray
= 1;
2033 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2034 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2035 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2040 /* Create an implicit second parameter from the loop variable. */
2041 gcc_assert (!arg2
->expr
);
2042 gcc_assert (corank
> 0);
2043 gcc_assert (se
->loop
->dimen
== 1);
2044 gcc_assert (se
->ss
->info
->expr
== expr
);
2046 bound
= se
->loop
->loopvar
[0];
2047 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2048 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2049 gfc_advance_se_ss_chain (se
);
2053 /* use the passed argument. */
2054 gcc_assert (arg2
->expr
);
2055 gfc_init_se (&argse
, NULL
);
2056 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2057 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2060 if (INTEGER_CST_P (bound
))
2062 if (wi::ltu_p (bound
, 1)
2063 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2064 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2065 "dimension index", expr
->value
.function
.isym
->name
,
2068 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2070 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2071 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2072 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2073 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2074 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2076 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2077 boolean_type_node
, cond
, tmp
);
2078 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2083 /* Subtract 1 to get to zero based and add dimensions. */
2084 switch (arg
->expr
->rank
)
2087 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2088 gfc_array_index_type
, bound
,
2089 gfc_index_one_node
);
2093 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2094 gfc_array_index_type
, bound
,
2095 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2099 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2101 /* Handle UCOBOUND with special handling of the last codimension. */
2102 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2104 /* Last codimension: For -fcoarray=single just return
2105 the lcobound - otherwise add
2106 ceiling (real (num_images ()) / real (size)) - 1
2107 = (num_images () + size - 1) / size - 1
2108 = (num_images - 1) / size(),
2109 where size is the product of the extent of all but the last
2112 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2116 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2117 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2118 2, integer_zero_node
,
2119 build_int_cst (integer_type_node
, -1));
2120 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2121 gfc_array_index_type
,
2122 fold_convert (gfc_array_index_type
, tmp
),
2123 build_int_cst (gfc_array_index_type
, 1));
2124 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2125 gfc_array_index_type
, tmp
,
2126 fold_convert (gfc_array_index_type
, cosize
));
2127 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2128 gfc_array_index_type
, resbound
, tmp
);
2130 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2132 /* ubound = lbound + num_images() - 1. */
2133 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2134 2, integer_zero_node
,
2135 build_int_cst (integer_type_node
, -1));
2136 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2137 gfc_array_index_type
,
2138 fold_convert (gfc_array_index_type
, tmp
),
2139 build_int_cst (gfc_array_index_type
, 1));
2140 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2141 gfc_array_index_type
, resbound
, tmp
);
2146 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2148 build_int_cst (TREE_TYPE (bound
),
2149 arg
->expr
->rank
+ corank
- 1));
2151 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2152 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2153 gfc_array_index_type
, cond
,
2154 resbound
, resbound2
);
2157 se
->expr
= resbound
;
2160 se
->expr
= resbound
;
2162 type
= gfc_typenode_for_spec (&expr
->ts
);
2163 se
->expr
= convert (type
, se
->expr
);
2168 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2170 gfc_actual_arglist
*array_arg
;
2171 gfc_actual_arglist
*dim_arg
;
2175 array_arg
= expr
->value
.function
.actual
;
2176 dim_arg
= array_arg
->next
;
2178 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2180 gfc_init_se (&argse
, NULL
);
2181 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2182 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2183 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2186 gcc_assert (dim_arg
->expr
);
2187 gfc_init_se (&argse
, NULL
);
2188 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2189 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2190 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2191 argse
.expr
, gfc_index_one_node
);
2192 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2197 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2201 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2203 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2207 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2212 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2213 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2222 /* Create a complex value from one or two real components. */
2225 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2231 unsigned int num_args
;
2233 num_args
= gfc_intrinsic_argument_list_length (expr
);
2234 args
= XALLOCAVEC (tree
, num_args
);
2236 type
= gfc_typenode_for_spec (&expr
->ts
);
2237 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2238 real
= convert (TREE_TYPE (type
), args
[0]);
2240 imag
= convert (TREE_TYPE (type
), args
[1]);
2241 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2243 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2244 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2245 imag
= convert (TREE_TYPE (type
), imag
);
2248 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2250 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2254 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2255 MODULO(A, P) = A - FLOOR (A / P) * P
2257 The obvious algorithms above are numerically instable for large
2258 arguments, hence these intrinsics are instead implemented via calls
2259 to the fmod family of functions. It is the responsibility of the
2260 user to ensure that the second argument is non-zero. */
2263 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2273 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2275 switch (expr
->ts
.type
)
2278 /* Integer case is easy, we've got a builtin op. */
2279 type
= TREE_TYPE (args
[0]);
2282 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2285 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2291 /* Check if we have a builtin fmod. */
2292 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2294 /* The builtin should always be available. */
2295 gcc_assert (fmod
!= NULL_TREE
);
2297 tmp
= build_addr (fmod
);
2298 se
->expr
= build_call_array_loc (input_location
,
2299 TREE_TYPE (TREE_TYPE (fmod
)),
2304 type
= TREE_TYPE (args
[0]);
2306 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2307 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2310 modulo = arg - floor (arg/arg2) * arg2
2312 In order to calculate the result accurately, we use the fmod
2313 function as follows.
2315 res = fmod (arg, arg2);
2318 if ((arg < 0) xor (arg2 < 0))
2322 res = copysign (0., arg2);
2324 => As two nested ternary exprs:
2326 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2327 : copysign (0., arg2);
2331 zero
= gfc_build_const (type
, integer_zero_node
);
2332 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2333 if (!flag_signed_zeros
)
2335 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2337 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2339 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2340 boolean_type_node
, test
, test2
);
2341 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2343 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2344 boolean_type_node
, test
, test2
);
2345 test
= gfc_evaluate_now (test
, &se
->pre
);
2346 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2347 fold_build2_loc (input_location
,
2349 type
, tmp
, args
[1]),
2354 tree expr1
, copysign
, cscall
;
2355 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2357 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2359 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2361 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2362 boolean_type_node
, test
, test2
);
2363 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2364 fold_build2_loc (input_location
,
2366 type
, tmp
, args
[1]),
2368 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2370 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2372 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2382 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2383 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2384 where the right shifts are logical (i.e. 0's are shifted in).
2385 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2386 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2388 DSHIFTL(I,J,BITSIZE) = J
2390 DSHIFTR(I,J,BITSIZE) = I. */
2393 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2395 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2396 tree args
[3], cond
, tmp
;
2399 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2401 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2402 type
= TREE_TYPE (args
[0]);
2403 bitsize
= TYPE_PRECISION (type
);
2404 utype
= unsigned_type_for (type
);
2405 stype
= TREE_TYPE (args
[2]);
2407 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2408 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2409 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2411 /* The generic case. */
2412 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2413 build_int_cst (stype
, bitsize
), shift
);
2414 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2415 arg1
, dshiftl
? shift
: tmp
);
2417 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2418 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2419 right
= fold_convert (type
, right
);
2421 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2423 /* Special cases. */
2424 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2425 build_int_cst (stype
, 0));
2426 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2427 dshiftl
? arg1
: arg2
, res
);
2429 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2430 build_int_cst (stype
, bitsize
));
2431 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2432 dshiftl
? arg2
: arg1
, res
);
2438 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2441 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2449 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2450 type
= TREE_TYPE (args
[0]);
2452 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2453 val
= gfc_evaluate_now (val
, &se
->pre
);
2455 zero
= gfc_build_const (type
, integer_zero_node
);
2456 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2457 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2461 /* SIGN(A, B) is absolute value of A times sign of B.
2462 The real value versions use library functions to ensure the correct
2463 handling of negative zero. Integer case implemented as:
2464 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2468 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2474 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2475 if (expr
->ts
.type
== BT_REAL
)
2479 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2480 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2482 /* We explicitly have to ignore the minus sign. We do so by using
2483 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2485 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2488 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2489 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2491 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2492 TREE_TYPE (args
[0]), cond
,
2493 build_call_expr_loc (input_location
, abs
, 1,
2495 build_call_expr_loc (input_location
, tmp
, 2,
2499 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2504 /* Having excluded floating point types, we know we are now dealing
2505 with signed integer types. */
2506 type
= TREE_TYPE (args
[0]);
2508 /* Args[0] is used multiple times below. */
2509 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2511 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2512 the signs of A and B are the same, and of all ones if they differ. */
2513 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2514 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2515 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2516 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2518 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2519 is all ones (i.e. -1). */
2520 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2521 fold_build2_loc (input_location
, PLUS_EXPR
,
2522 type
, args
[0], tmp
), tmp
);
2526 /* Test for the presence of an optional argument. */
2529 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2533 arg
= expr
->value
.function
.actual
->expr
;
2534 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2535 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2536 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2540 /* Calculate the double precision product of two single precision values. */
2543 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2548 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2550 /* Convert the args to double precision before multiplying. */
2551 type
= gfc_typenode_for_spec (&expr
->ts
);
2552 args
[0] = convert (type
, args
[0]);
2553 args
[1] = convert (type
, args
[1]);
2554 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2559 /* Return a length one character string containing an ascii character. */
2562 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2567 unsigned int num_args
;
2569 num_args
= gfc_intrinsic_argument_list_length (expr
);
2570 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2572 type
= gfc_get_char_type (expr
->ts
.kind
);
2573 var
= gfc_create_var (type
, "char");
2575 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2576 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2577 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2578 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2583 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2591 unsigned int num_args
;
2593 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2594 args
= XALLOCAVEC (tree
, num_args
);
2596 var
= gfc_create_var (pchar_type_node
, "pstr");
2597 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2599 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2600 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2601 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2603 fndecl
= build_addr (gfor_fndecl_ctime
);
2604 tmp
= build_call_array_loc (input_location
,
2605 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2606 fndecl
, num_args
, args
);
2607 gfc_add_expr_to_block (&se
->pre
, tmp
);
2609 /* Free the temporary afterwards, if necessary. */
2610 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2611 len
, build_int_cst (TREE_TYPE (len
), 0));
2612 tmp
= gfc_call_free (var
);
2613 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2614 gfc_add_expr_to_block (&se
->post
, tmp
);
2617 se
->string_length
= len
;
2622 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2630 unsigned int num_args
;
2632 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2633 args
= XALLOCAVEC (tree
, num_args
);
2635 var
= gfc_create_var (pchar_type_node
, "pstr");
2636 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2638 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2639 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2640 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2642 fndecl
= build_addr (gfor_fndecl_fdate
);
2643 tmp
= build_call_array_loc (input_location
,
2644 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2645 fndecl
, num_args
, args
);
2646 gfc_add_expr_to_block (&se
->pre
, tmp
);
2648 /* Free the temporary afterwards, if necessary. */
2649 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2650 len
, build_int_cst (TREE_TYPE (len
), 0));
2651 tmp
= gfc_call_free (var
);
2652 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2653 gfc_add_expr_to_block (&se
->post
, tmp
);
2656 se
->string_length
= len
;
2660 /* Generate a direct call to free() for the FREE subroutine. */
2663 conv_intrinsic_free (gfc_code
*code
)
2669 gfc_init_se (&argse
, NULL
);
2670 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
2671 arg
= fold_convert (ptr_type_node
, argse
.expr
);
2673 gfc_init_block (&block
);
2674 call
= build_call_expr_loc (input_location
,
2675 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
2676 gfc_add_expr_to_block (&block
, call
);
2677 return gfc_finish_block (&block
);
2681 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2685 conv_intrinsic_system_clock (gfc_code
*code
)
2688 gfc_se count_se
, count_rate_se
, count_max_se
;
2689 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
2693 gfc_expr
*count
= code
->ext
.actual
->expr
;
2694 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
2695 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
2697 /* Evaluate our arguments. */
2700 gfc_init_se (&count_se
, NULL
);
2701 gfc_conv_expr (&count_se
, count
);
2706 gfc_init_se (&count_rate_se
, NULL
);
2707 gfc_conv_expr (&count_rate_se
, count_rate
);
2712 gfc_init_se (&count_max_se
, NULL
);
2713 gfc_conv_expr (&count_max_se
, count_max
);
2716 /* Find the smallest kind found of the arguments. */
2718 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
2719 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
2721 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
2724 /* Prepare temporary variables. */
2729 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
2730 else if (least
== 4)
2731 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
2732 else if (count
->ts
.kind
== 1)
2733 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
2736 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
2743 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
2744 else if (least
== 4)
2745 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
2747 arg2
= integer_zero_node
;
2753 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
2754 else if (least
== 4)
2755 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
2757 arg3
= integer_zero_node
;
2760 /* Make the function call. */
2761 gfc_init_block (&block
);
2767 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2768 : null_pointer_node
;
2769 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2770 : null_pointer_node
;
2771 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2772 : null_pointer_node
;
2777 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2778 : null_pointer_node
;
2779 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2780 : null_pointer_node
;
2781 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2782 : null_pointer_node
;
2789 tmp
= build_call_expr_loc (input_location
,
2790 gfor_fndecl_system_clock4
, 3,
2791 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2792 : null_pointer_node
,
2793 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2794 : null_pointer_node
,
2795 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2796 : null_pointer_node
);
2797 gfc_add_expr_to_block (&block
, tmp
);
2799 /* Handle kind>=8, 10, or 16 arguments */
2802 tmp
= build_call_expr_loc (input_location
,
2803 gfor_fndecl_system_clock8
, 3,
2804 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2805 : null_pointer_node
,
2806 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2807 : null_pointer_node
,
2808 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2809 : null_pointer_node
);
2810 gfc_add_expr_to_block (&block
, tmp
);
2814 /* And store values back if needed. */
2815 if (arg1
&& arg1
!= count_se
.expr
)
2816 gfc_add_modify (&block
, count_se
.expr
,
2817 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
2818 if (arg2
&& arg2
!= count_rate_se
.expr
)
2819 gfc_add_modify (&block
, count_rate_se
.expr
,
2820 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
2821 if (arg3
&& arg3
!= count_max_se
.expr
)
2822 gfc_add_modify (&block
, count_max_se
.expr
,
2823 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
2825 return gfc_finish_block (&block
);
2829 /* Return a character string containing the tty name. */
2832 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2840 unsigned int num_args
;
2842 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2843 args
= XALLOCAVEC (tree
, num_args
);
2845 var
= gfc_create_var (pchar_type_node
, "pstr");
2846 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2848 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2849 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2850 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2852 fndecl
= build_addr (gfor_fndecl_ttynam
);
2853 tmp
= build_call_array_loc (input_location
,
2854 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2855 fndecl
, num_args
, args
);
2856 gfc_add_expr_to_block (&se
->pre
, tmp
);
2858 /* Free the temporary afterwards, if necessary. */
2859 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2860 len
, build_int_cst (TREE_TYPE (len
), 0));
2861 tmp
= gfc_call_free (var
);
2862 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2863 gfc_add_expr_to_block (&se
->post
, tmp
);
2866 se
->string_length
= len
;
2870 /* Get the minimum/maximum value of all the parameters.
2871 minmax (a1, a2, a3, ...)
2874 if (a2 .op. mvar || isnan (mvar))
2876 if (a3 .op. mvar || isnan (mvar))
2883 /* TODO: Mismatching types can occur when specific names are used.
2884 These should be handled during resolution. */
2886 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2894 gfc_actual_arglist
*argexpr
;
2895 unsigned int i
, nargs
;
2897 nargs
= gfc_intrinsic_argument_list_length (expr
);
2898 args
= XALLOCAVEC (tree
, nargs
);
2900 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2901 type
= gfc_typenode_for_spec (&expr
->ts
);
2903 argexpr
= expr
->value
.function
.actual
;
2904 if (TREE_TYPE (args
[0]) != type
)
2905 args
[0] = convert (type
, args
[0]);
2906 /* Only evaluate the argument once. */
2907 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2908 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2910 mvar
= gfc_create_var (type
, "M");
2911 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2912 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2918 /* Handle absent optional arguments by ignoring the comparison. */
2919 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2920 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2921 && TREE_CODE (val
) == INDIRECT_REF
)
2922 cond
= fold_build2_loc (input_location
,
2923 NE_EXPR
, boolean_type_node
,
2924 TREE_OPERAND (val
, 0),
2925 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2930 /* Only evaluate the argument once. */
2931 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2932 val
= gfc_evaluate_now (val
, &se
->pre
);
2935 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2937 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2938 convert (type
, val
), mvar
);
2940 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2941 __builtin_isnan might be made dependent on that module being loaded,
2942 to help performance of programs that don't rely on IEEE semantics. */
2943 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2945 isnan
= build_call_expr_loc (input_location
,
2946 builtin_decl_explicit (BUILT_IN_ISNAN
),
2948 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2949 boolean_type_node
, tmp
,
2950 fold_convert (boolean_type_node
, isnan
));
2952 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2953 build_empty_stmt (input_location
));
2955 if (cond
!= NULL_TREE
)
2956 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2957 build_empty_stmt (input_location
));
2959 gfc_add_expr_to_block (&se
->pre
, tmp
);
2960 argexpr
= argexpr
->next
;
2966 /* Generate library calls for MIN and MAX intrinsics for character
2969 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2972 tree var
, len
, fndecl
, tmp
, cond
, function
;
2975 nargs
= gfc_intrinsic_argument_list_length (expr
);
2976 args
= XALLOCAVEC (tree
, nargs
+ 4);
2977 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2979 /* Create the result variables. */
2980 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2981 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2982 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2983 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2984 args
[2] = build_int_cst (integer_type_node
, op
);
2985 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2987 if (expr
->ts
.kind
== 1)
2988 function
= gfor_fndecl_string_minmax
;
2989 else if (expr
->ts
.kind
== 4)
2990 function
= gfor_fndecl_string_minmax_char4
;
2994 /* Make the function call. */
2995 fndecl
= build_addr (function
);
2996 tmp
= build_call_array_loc (input_location
,
2997 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2999 gfc_add_expr_to_block (&se
->pre
, tmp
);
3001 /* Free the temporary afterwards, if necessary. */
3002 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3003 len
, build_int_cst (TREE_TYPE (len
), 0));
3004 tmp
= gfc_call_free (var
);
3005 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3006 gfc_add_expr_to_block (&se
->post
, tmp
);
3009 se
->string_length
= len
;
3013 /* Create a symbol node for this intrinsic. The symbol from the frontend
3014 has the generic name. */
3017 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3021 /* TODO: Add symbols for intrinsic function to the global namespace. */
3022 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3023 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3026 sym
->attr
.external
= 1;
3027 sym
->attr
.function
= 1;
3028 sym
->attr
.always_explicit
= 1;
3029 sym
->attr
.proc
= PROC_INTRINSIC
;
3030 sym
->attr
.flavor
= FL_PROCEDURE
;
3034 sym
->attr
.dimension
= 1;
3035 sym
->as
= gfc_get_array_spec ();
3036 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3037 sym
->as
->rank
= expr
->rank
;
3040 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3041 ignore_optional
? expr
->value
.function
.actual
3047 /* Generate a call to an external intrinsic function. */
3049 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3052 vec
<tree
, va_gc
> *append_args
;
3054 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3057 gcc_assert (expr
->rank
> 0);
3059 gcc_assert (expr
->rank
== 0);
3061 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3063 /* Calls to libgfortran_matmul need to be appended special arguments,
3064 to be able to call the BLAS ?gemm functions if required and possible. */
3066 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3067 && sym
->ts
.type
!= BT_LOGICAL
)
3069 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3071 if (flag_external_blas
3072 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3073 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3077 if (sym
->ts
.type
== BT_REAL
)
3079 if (sym
->ts
.kind
== 4)
3080 gemm_fndecl
= gfor_fndecl_sgemm
;
3082 gemm_fndecl
= gfor_fndecl_dgemm
;
3086 if (sym
->ts
.kind
== 4)
3087 gemm_fndecl
= gfor_fndecl_cgemm
;
3089 gemm_fndecl
= gfor_fndecl_zgemm
;
3092 vec_alloc (append_args
, 3);
3093 append_args
->quick_push (build_int_cst (cint
, 1));
3094 append_args
->quick_push (build_int_cst (cint
,
3095 flag_blas_matmul_limit
));
3096 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3101 vec_alloc (append_args
, 3);
3102 append_args
->quick_push (build_int_cst (cint
, 0));
3103 append_args
->quick_push (build_int_cst (cint
, 0));
3104 append_args
->quick_push (null_pointer_node
);
3108 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3110 gfc_free_symbol (sym
);
3113 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3133 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3142 gfc_actual_arglist
*actual
;
3149 gfc_conv_intrinsic_funcall (se
, expr
);
3153 actual
= expr
->value
.function
.actual
;
3154 type
= gfc_typenode_for_spec (&expr
->ts
);
3155 /* Initialize the result. */
3156 resvar
= gfc_create_var (type
, "test");
3158 tmp
= convert (type
, boolean_true_node
);
3160 tmp
= convert (type
, boolean_false_node
);
3161 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3163 /* Walk the arguments. */
3164 arrayss
= gfc_walk_expr (actual
->expr
);
3165 gcc_assert (arrayss
!= gfc_ss_terminator
);
3167 /* Initialize the scalarizer. */
3168 gfc_init_loopinfo (&loop
);
3169 exit_label
= gfc_build_label_decl (NULL_TREE
);
3170 TREE_USED (exit_label
) = 1;
3171 gfc_add_ss_to_loop (&loop
, arrayss
);
3173 /* Initialize the loop. */
3174 gfc_conv_ss_startstride (&loop
);
3175 gfc_conv_loop_setup (&loop
, &expr
->where
);
3177 gfc_mark_ss_chain_used (arrayss
, 1);
3178 /* Generate the loop body. */
3179 gfc_start_scalarized_body (&loop
, &body
);
3181 /* If the condition matches then set the return value. */
3182 gfc_start_block (&block
);
3184 tmp
= convert (type
, boolean_false_node
);
3186 tmp
= convert (type
, boolean_true_node
);
3187 gfc_add_modify (&block
, resvar
, tmp
);
3189 /* And break out of the loop. */
3190 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3191 gfc_add_expr_to_block (&block
, tmp
);
3193 found
= gfc_finish_block (&block
);
3195 /* Check this element. */
3196 gfc_init_se (&arrayse
, NULL
);
3197 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3198 arrayse
.ss
= arrayss
;
3199 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3201 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3202 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3203 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3204 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3205 gfc_add_expr_to_block (&body
, tmp
);
3206 gfc_add_block_to_block (&body
, &arrayse
.post
);
3208 gfc_trans_scalarizing_loops (&loop
, &body
);
3210 /* Add the exit label. */
3211 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3212 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3214 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3215 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3216 gfc_cleanup_loop (&loop
);
3221 /* COUNT(A) = Number of true elements in A. */
3223 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3230 gfc_actual_arglist
*actual
;
3236 gfc_conv_intrinsic_funcall (se
, expr
);
3240 actual
= expr
->value
.function
.actual
;
3242 type
= gfc_typenode_for_spec (&expr
->ts
);
3243 /* Initialize the result. */
3244 resvar
= gfc_create_var (type
, "count");
3245 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3247 /* Walk the arguments. */
3248 arrayss
= gfc_walk_expr (actual
->expr
);
3249 gcc_assert (arrayss
!= gfc_ss_terminator
);
3251 /* Initialize the scalarizer. */
3252 gfc_init_loopinfo (&loop
);
3253 gfc_add_ss_to_loop (&loop
, arrayss
);
3255 /* Initialize the loop. */
3256 gfc_conv_ss_startstride (&loop
);
3257 gfc_conv_loop_setup (&loop
, &expr
->where
);
3259 gfc_mark_ss_chain_used (arrayss
, 1);
3260 /* Generate the loop body. */
3261 gfc_start_scalarized_body (&loop
, &body
);
3263 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3264 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3265 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3267 gfc_init_se (&arrayse
, NULL
);
3268 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3269 arrayse
.ss
= arrayss
;
3270 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3271 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
3272 build_empty_stmt (input_location
));
3274 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3275 gfc_add_expr_to_block (&body
, tmp
);
3276 gfc_add_block_to_block (&body
, &arrayse
.post
);
3278 gfc_trans_scalarizing_loops (&loop
, &body
);
3280 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3281 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3282 gfc_cleanup_loop (&loop
);
3288 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3289 struct and return the corresponding loopinfo. */
3291 static gfc_loopinfo
*
3292 enter_nested_loop (gfc_se
*se
)
3294 se
->ss
= se
->ss
->nested_ss
;
3295 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
3297 return se
->ss
->loop
;
3301 /* Inline implementation of the sum and product intrinsics. */
3303 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
3307 tree scale
= NULL_TREE
;
3312 gfc_loopinfo loop
, *ploop
;
3313 gfc_actual_arglist
*arg_array
, *arg_mask
;
3314 gfc_ss
*arrayss
= NULL
;
3315 gfc_ss
*maskss
= NULL
;
3319 gfc_expr
*arrayexpr
;
3324 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
3330 type
= gfc_typenode_for_spec (&expr
->ts
);
3331 /* Initialize the result. */
3332 resvar
= gfc_create_var (type
, "val");
3337 scale
= gfc_create_var (type
, "scale");
3338 gfc_add_modify (&se
->pre
, scale
,
3339 gfc_build_const (type
, integer_one_node
));
3340 tmp
= gfc_build_const (type
, integer_zero_node
);
3342 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
3343 tmp
= gfc_build_const (type
, integer_zero_node
);
3344 else if (op
== NE_EXPR
)
3346 tmp
= convert (type
, boolean_false_node
);
3347 else if (op
== BIT_AND_EXPR
)
3348 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
3349 type
, integer_one_node
));
3351 tmp
= gfc_build_const (type
, integer_one_node
);
3353 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3355 arg_array
= expr
->value
.function
.actual
;
3357 arrayexpr
= arg_array
->expr
;
3359 if (op
== NE_EXPR
|| norm2
)
3360 /* PARITY and NORM2. */
3364 arg_mask
= arg_array
->next
->next
;
3365 gcc_assert (arg_mask
!= NULL
);
3366 maskexpr
= arg_mask
->expr
;
3369 if (expr
->rank
== 0)
3371 /* Walk the arguments. */
3372 arrayss
= gfc_walk_expr (arrayexpr
);
3373 gcc_assert (arrayss
!= gfc_ss_terminator
);
3375 if (maskexpr
&& maskexpr
->rank
> 0)
3377 maskss
= gfc_walk_expr (maskexpr
);
3378 gcc_assert (maskss
!= gfc_ss_terminator
);
3383 /* Initialize the scalarizer. */
3384 gfc_init_loopinfo (&loop
);
3385 gfc_add_ss_to_loop (&loop
, arrayss
);
3386 if (maskexpr
&& maskexpr
->rank
> 0)
3387 gfc_add_ss_to_loop (&loop
, maskss
);
3389 /* Initialize the loop. */
3390 gfc_conv_ss_startstride (&loop
);
3391 gfc_conv_loop_setup (&loop
, &expr
->where
);
3393 gfc_mark_ss_chain_used (arrayss
, 1);
3394 if (maskexpr
&& maskexpr
->rank
> 0)
3395 gfc_mark_ss_chain_used (maskss
, 1);
3400 /* All the work has been done in the parent loops. */
3401 ploop
= enter_nested_loop (se
);
3405 /* Generate the loop body. */
3406 gfc_start_scalarized_body (ploop
, &body
);
3408 /* If we have a mask, only add this element if the mask is set. */
3409 if (maskexpr
&& maskexpr
->rank
> 0)
3411 gfc_init_se (&maskse
, parent_se
);
3412 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
3413 if (expr
->rank
== 0)
3415 gfc_conv_expr_val (&maskse
, maskexpr
);
3416 gfc_add_block_to_block (&body
, &maskse
.pre
);
3418 gfc_start_block (&block
);
3421 gfc_init_block (&block
);
3423 /* Do the actual summation/product. */
3424 gfc_init_se (&arrayse
, parent_se
);
3425 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
3426 if (expr
->rank
== 0)
3427 arrayse
.ss
= arrayss
;
3428 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3429 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3433 /* if (x (i) != 0.0)
3439 result = 1.0 + result * val * val;
3445 result += val * val;
3448 tree res1
, res2
, cond
, absX
, val
;
3449 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3451 gfc_init_block (&ifblock1
);
3453 absX
= gfc_create_var (type
, "absX");
3454 gfc_add_modify (&ifblock1
, absX
,
3455 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3457 val
= gfc_create_var (type
, "val");
3458 gfc_add_expr_to_block (&ifblock1
, val
);
3460 gfc_init_block (&ifblock2
);
3461 gfc_add_modify (&ifblock2
, val
,
3462 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3464 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3465 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3466 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3467 gfc_build_const (type
, integer_one_node
));
3468 gfc_add_modify (&ifblock2
, resvar
, res1
);
3469 gfc_add_modify (&ifblock2
, scale
, absX
);
3470 res1
= gfc_finish_block (&ifblock2
);
3472 gfc_init_block (&ifblock3
);
3473 gfc_add_modify (&ifblock3
, val
,
3474 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3476 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3477 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3478 gfc_add_modify (&ifblock3
, resvar
, res2
);
3479 res2
= gfc_finish_block (&ifblock3
);
3481 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3483 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3484 gfc_add_expr_to_block (&ifblock1
, tmp
);
3485 tmp
= gfc_finish_block (&ifblock1
);
3487 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3489 gfc_build_const (type
, integer_zero_node
));
3491 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3492 gfc_add_expr_to_block (&block
, tmp
);
3496 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3497 gfc_add_modify (&block
, resvar
, tmp
);
3500 gfc_add_block_to_block (&block
, &arrayse
.post
);
3502 if (maskexpr
&& maskexpr
->rank
> 0)
3504 /* We enclose the above in if (mask) {...} . */
3506 tmp
= gfc_finish_block (&block
);
3507 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3508 build_empty_stmt (input_location
));
3511 tmp
= gfc_finish_block (&block
);
3512 gfc_add_expr_to_block (&body
, tmp
);
3514 gfc_trans_scalarizing_loops (ploop
, &body
);
3516 /* For a scalar mask, enclose the loop in an if statement. */
3517 if (maskexpr
&& maskexpr
->rank
== 0)
3519 gfc_init_block (&block
);
3520 gfc_add_block_to_block (&block
, &ploop
->pre
);
3521 gfc_add_block_to_block (&block
, &ploop
->post
);
3522 tmp
= gfc_finish_block (&block
);
3526 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3527 build_empty_stmt (input_location
));
3528 gfc_advance_se_ss_chain (se
);
3532 gcc_assert (expr
->rank
== 0);
3533 gfc_init_se (&maskse
, NULL
);
3534 gfc_conv_expr_val (&maskse
, maskexpr
);
3535 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3536 build_empty_stmt (input_location
));
3539 gfc_add_expr_to_block (&block
, tmp
);
3540 gfc_add_block_to_block (&se
->pre
, &block
);
3541 gcc_assert (se
->post
.head
== NULL
);
3545 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3546 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3549 if (expr
->rank
== 0)
3550 gfc_cleanup_loop (ploop
);
3554 /* result = scale * sqrt(result). */
3556 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3557 resvar
= build_call_expr_loc (input_location
,
3559 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3566 /* Inline implementation of the dot_product intrinsic. This function
3567 is based on gfc_conv_intrinsic_arith (the previous function). */
3569 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3577 gfc_actual_arglist
*actual
;
3578 gfc_ss
*arrayss1
, *arrayss2
;
3579 gfc_se arrayse1
, arrayse2
;
3580 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3582 type
= gfc_typenode_for_spec (&expr
->ts
);
3584 /* Initialize the result. */
3585 resvar
= gfc_create_var (type
, "val");
3586 if (expr
->ts
.type
== BT_LOGICAL
)
3587 tmp
= build_int_cst (type
, 0);
3589 tmp
= gfc_build_const (type
, integer_zero_node
);
3591 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3593 /* Walk argument #1. */
3594 actual
= expr
->value
.function
.actual
;
3595 arrayexpr1
= actual
->expr
;
3596 arrayss1
= gfc_walk_expr (arrayexpr1
);
3597 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3599 /* Walk argument #2. */
3600 actual
= actual
->next
;
3601 arrayexpr2
= actual
->expr
;
3602 arrayss2
= gfc_walk_expr (arrayexpr2
);
3603 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3605 /* Initialize the scalarizer. */
3606 gfc_init_loopinfo (&loop
);
3607 gfc_add_ss_to_loop (&loop
, arrayss1
);
3608 gfc_add_ss_to_loop (&loop
, arrayss2
);
3610 /* Initialize the loop. */
3611 gfc_conv_ss_startstride (&loop
);
3612 gfc_conv_loop_setup (&loop
, &expr
->where
);
3614 gfc_mark_ss_chain_used (arrayss1
, 1);
3615 gfc_mark_ss_chain_used (arrayss2
, 1);
3617 /* Generate the loop body. */
3618 gfc_start_scalarized_body (&loop
, &body
);
3619 gfc_init_block (&block
);
3621 /* Make the tree expression for [conjg(]array1[)]. */
3622 gfc_init_se (&arrayse1
, NULL
);
3623 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3624 arrayse1
.ss
= arrayss1
;
3625 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3626 if (expr
->ts
.type
== BT_COMPLEX
)
3627 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3629 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3631 /* Make the tree expression for array2. */
3632 gfc_init_se (&arrayse2
, NULL
);
3633 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3634 arrayse2
.ss
= arrayss2
;
3635 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3636 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3638 /* Do the actual product and sum. */
3639 if (expr
->ts
.type
== BT_LOGICAL
)
3641 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3642 arrayse1
.expr
, arrayse2
.expr
);
3643 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3647 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3649 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3651 gfc_add_modify (&block
, resvar
, tmp
);
3653 /* Finish up the loop block and the loop. */
3654 tmp
= gfc_finish_block (&block
);
3655 gfc_add_expr_to_block (&body
, tmp
);
3657 gfc_trans_scalarizing_loops (&loop
, &body
);
3658 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3659 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3660 gfc_cleanup_loop (&loop
);
3666 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3667 we need to handle. For performance reasons we sometimes create two
3668 loops instead of one, where the second one is much simpler.
3669 Examples for minloc intrinsic:
3670 1) Result is an array, a call is generated
3671 2) Array mask is used and NaNs need to be supported:
3677 if (pos == 0) pos = S + (1 - from);
3678 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3685 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3689 3) NaNs need to be supported, but it is known at compile time or cheaply
3690 at runtime whether array is nonempty or not:
3695 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3698 if (from <= to) pos = 1;
3702 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3706 4) NaNs aren't supported, array mask is used:
3707 limit = infinities_supported ? Infinity : huge (limit);
3711 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3717 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3721 5) Same without array mask:
3722 limit = infinities_supported ? Infinity : huge (limit);
3723 pos = (from <= to) ? 1 : 0;
3726 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3729 For 3) and 5), if mask is scalar, this all goes into a conditional,
3730 setting pos = 0; in the else branch. */
3733 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3737 stmtblock_t ifblock
;
3738 stmtblock_t elseblock
;
3749 gfc_actual_arglist
*actual
;
3754 gfc_expr
*arrayexpr
;
3761 gfc_conv_intrinsic_funcall (se
, expr
);
3765 /* Initialize the result. */
3766 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3767 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3768 type
= gfc_typenode_for_spec (&expr
->ts
);
3770 /* Walk the arguments. */
3771 actual
= expr
->value
.function
.actual
;
3772 arrayexpr
= actual
->expr
;
3773 arrayss
= gfc_walk_expr (arrayexpr
);
3774 gcc_assert (arrayss
!= gfc_ss_terminator
);
3776 actual
= actual
->next
->next
;
3777 gcc_assert (actual
);
3778 maskexpr
= actual
->expr
;
3780 if (maskexpr
&& maskexpr
->rank
!= 0)
3782 maskss
= gfc_walk_expr (maskexpr
);
3783 gcc_assert (maskss
!= gfc_ss_terminator
);
3788 if (gfc_array_size (arrayexpr
, &asize
))
3790 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3792 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3793 boolean_type_node
, nonempty
,
3794 gfc_index_zero_node
);
3799 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3800 switch (arrayexpr
->ts
.type
)
3803 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3807 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3808 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3809 arrayexpr
->ts
.kind
);
3816 /* We start with the most negative possible value for MAXLOC, and the most
3817 positive possible value for MINLOC. The most negative possible value is
3818 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3819 possible value is HUGE in both cases. */
3821 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3822 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
3823 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3824 build_int_cst (TREE_TYPE (tmp
), 1));
3826 gfc_add_modify (&se
->pre
, limit
, tmp
);
3828 /* Initialize the scalarizer. */
3829 gfc_init_loopinfo (&loop
);
3830 gfc_add_ss_to_loop (&loop
, arrayss
);
3832 gfc_add_ss_to_loop (&loop
, maskss
);
3834 /* Initialize the loop. */
3835 gfc_conv_ss_startstride (&loop
);
3837 /* The code generated can have more than one loop in sequence (see the
3838 comment at the function header). This doesn't work well with the
3839 scalarizer, which changes arrays' offset when the scalarization loops
3840 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3841 are currently inlined in the scalar case only (for which loop is of rank
3842 one). As there is no dependency to care about in that case, there is no
3843 temporary, so that we can use the scalarizer temporary code to handle
3844 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3845 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3847 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3848 should eventually go away. We could either create two loops properly,
3849 or find another way to save/restore the array offsets between the two
3850 loops (without conflicting with temporary management), or use a single
3851 loop minmaxloc implementation. See PR 31067. */
3852 loop
.temp_dim
= loop
.dimen
;
3853 gfc_conv_loop_setup (&loop
, &expr
->where
);
3855 gcc_assert (loop
.dimen
== 1);
3856 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3857 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3858 loop
.from
[0], loop
.to
[0]);
3862 /* Initialize the position to zero, following Fortran 2003. We are free
3863 to do this because Fortran 95 allows the result of an entirely false
3864 mask to be processor dependent. If we know at compile time the array
3865 is non-empty and no MASK is used, we can initialize to 1 to simplify
3867 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3868 gfc_add_modify (&loop
.pre
, pos
,
3869 fold_build3_loc (input_location
, COND_EXPR
,
3870 gfc_array_index_type
,
3871 nonempty
, gfc_index_one_node
,
3872 gfc_index_zero_node
));
3875 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3876 lab1
= gfc_build_label_decl (NULL_TREE
);
3877 TREE_USED (lab1
) = 1;
3878 lab2
= gfc_build_label_decl (NULL_TREE
);
3879 TREE_USED (lab2
) = 1;
3882 /* An offset must be added to the loop
3883 counter to obtain the required position. */
3884 gcc_assert (loop
.from
[0]);
3886 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3887 gfc_index_one_node
, loop
.from
[0]);
3888 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3890 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3892 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3893 /* Generate the loop body. */
3894 gfc_start_scalarized_body (&loop
, &body
);
3896 /* If we have a mask, only check this element if the mask is set. */
3899 gfc_init_se (&maskse
, NULL
);
3900 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3902 gfc_conv_expr_val (&maskse
, maskexpr
);
3903 gfc_add_block_to_block (&body
, &maskse
.pre
);
3905 gfc_start_block (&block
);
3908 gfc_init_block (&block
);
3910 /* Compare with the current limit. */
3911 gfc_init_se (&arrayse
, NULL
);
3912 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3913 arrayse
.ss
= arrayss
;
3914 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3915 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3917 /* We do the following if this is a more extreme value. */
3918 gfc_start_block (&ifblock
);
3920 /* Assign the value to the limit... */
3921 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3923 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3925 stmtblock_t ifblock2
;
3928 gfc_start_block (&ifblock2
);
3929 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3930 loop
.loopvar
[0], offset
);
3931 gfc_add_modify (&ifblock2
, pos
, tmp
);
3932 ifbody2
= gfc_finish_block (&ifblock2
);
3933 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3934 gfc_index_zero_node
);
3935 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3936 build_empty_stmt (input_location
));
3937 gfc_add_expr_to_block (&block
, tmp
);
3940 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3941 loop
.loopvar
[0], offset
);
3942 gfc_add_modify (&ifblock
, pos
, tmp
);
3945 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3947 ifbody
= gfc_finish_block (&ifblock
);
3949 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3952 cond
= fold_build2_loc (input_location
,
3953 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3954 boolean_type_node
, arrayse
.expr
, limit
);
3956 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3957 arrayse
.expr
, limit
);
3959 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3960 build_empty_stmt (input_location
));
3962 gfc_add_expr_to_block (&block
, ifbody
);
3966 /* We enclose the above in if (mask) {...}. */
3967 tmp
= gfc_finish_block (&block
);
3969 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3970 build_empty_stmt (input_location
));
3973 tmp
= gfc_finish_block (&block
);
3974 gfc_add_expr_to_block (&body
, tmp
);
3978 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3980 if (HONOR_NANS (DECL_MODE (limit
)))
3982 if (nonempty
!= NULL
)
3984 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3985 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3986 build_empty_stmt (input_location
));
3987 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3991 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3992 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3994 /* If we have a mask, only check this element if the mask is set. */
3997 gfc_init_se (&maskse
, NULL
);
3998 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4000 gfc_conv_expr_val (&maskse
, maskexpr
);
4001 gfc_add_block_to_block (&body
, &maskse
.pre
);
4003 gfc_start_block (&block
);
4006 gfc_init_block (&block
);
4008 /* Compare with the current limit. */
4009 gfc_init_se (&arrayse
, NULL
);
4010 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4011 arrayse
.ss
= arrayss
;
4012 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4013 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4015 /* We do the following if this is a more extreme value. */
4016 gfc_start_block (&ifblock
);
4018 /* Assign the value to the limit... */
4019 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4021 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4022 loop
.loopvar
[0], offset
);
4023 gfc_add_modify (&ifblock
, pos
, tmp
);
4025 ifbody
= gfc_finish_block (&ifblock
);
4027 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4028 arrayse
.expr
, limit
);
4030 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4031 build_empty_stmt (input_location
));
4032 gfc_add_expr_to_block (&block
, tmp
);
4036 /* We enclose the above in if (mask) {...}. */
4037 tmp
= gfc_finish_block (&block
);
4039 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4040 build_empty_stmt (input_location
));
4043 tmp
= gfc_finish_block (&block
);
4044 gfc_add_expr_to_block (&body
, tmp
);
4045 /* Avoid initializing loopvar[0] again, it should be left where
4046 it finished by the first loop. */
4047 loop
.from
[0] = loop
.loopvar
[0];
4050 gfc_trans_scalarizing_loops (&loop
, &body
);
4053 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4055 /* For a scalar mask, enclose the loop in an if statement. */
4056 if (maskexpr
&& maskss
== NULL
)
4058 gfc_init_se (&maskse
, NULL
);
4059 gfc_conv_expr_val (&maskse
, maskexpr
);
4060 gfc_init_block (&block
);
4061 gfc_add_block_to_block (&block
, &loop
.pre
);
4062 gfc_add_block_to_block (&block
, &loop
.post
);
4063 tmp
= gfc_finish_block (&block
);
4065 /* For the else part of the scalar mask, just initialize
4066 the pos variable the same way as above. */
4068 gfc_init_block (&elseblock
);
4069 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4070 elsetmp
= gfc_finish_block (&elseblock
);
4072 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4073 gfc_add_expr_to_block (&block
, tmp
);
4074 gfc_add_block_to_block (&se
->pre
, &block
);
4078 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4079 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4081 gfc_cleanup_loop (&loop
);
4083 se
->expr
= convert (type
, pos
);
4086 /* Emit code for minval or maxval intrinsic. There are many different cases
4087 we need to handle. For performance reasons we sometimes create two
4088 loops instead of one, where the second one is much simpler.
4089 Examples for minval intrinsic:
4090 1) Result is an array, a call is generated
4091 2) Array mask is used and NaNs need to be supported, rank 1:
4096 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4099 limit = nonempty ? NaN : huge (limit);
4101 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4102 3) NaNs need to be supported, but it is known at compile time or cheaply
4103 at runtime whether array is nonempty or not, rank 1:
4106 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4107 limit = (from <= to) ? NaN : huge (limit);
4109 while (S <= to) { limit = min (a[S], limit); S++; }
4110 4) Array mask is used and NaNs need to be supported, rank > 1:
4119 if (fast) limit = min (a[S1][S2], limit);
4122 if (a[S1][S2] <= limit) {
4133 limit = nonempty ? NaN : huge (limit);
4134 5) NaNs need to be supported, but it is known at compile time or cheaply
4135 at runtime whether array is nonempty or not, rank > 1:
4142 if (fast) limit = min (a[S1][S2], limit);
4144 if (a[S1][S2] <= limit) {
4154 limit = (nonempty_array) ? NaN : huge (limit);
4155 6) NaNs aren't supported, but infinities are. Array mask is used:
4160 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4163 limit = nonempty ? limit : huge (limit);
4164 7) Same without array mask:
4167 while (S <= to) { limit = min (a[S], limit); S++; }
4168 limit = (from <= to) ? limit : huge (limit);
4169 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4170 limit = huge (limit);
4172 while (S <= to) { limit = min (a[S], limit); S++); }
4174 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4175 with array mask instead).
4176 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4177 setting limit = huge (limit); in the else branch. */
4180 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4190 tree huge_cst
= NULL
, nan_cst
= NULL
;
4192 stmtblock_t block
, block2
;
4194 gfc_actual_arglist
*actual
;
4199 gfc_expr
*arrayexpr
;
4205 gfc_conv_intrinsic_funcall (se
, expr
);
4209 type
= gfc_typenode_for_spec (&expr
->ts
);
4210 /* Initialize the result. */
4211 limit
= gfc_create_var (type
, "limit");
4212 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4213 switch (expr
->ts
.type
)
4216 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4218 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4220 REAL_VALUE_TYPE real
;
4222 tmp
= build_real (type
, real
);
4226 if (HONOR_NANS (DECL_MODE (limit
)))
4227 nan_cst
= gfc_build_nan (type
, "");
4231 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4238 /* We start with the most negative possible value for MAXVAL, and the most
4239 positive possible value for MINVAL. The most negative possible value is
4240 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4241 possible value is HUGE in both cases. */
4244 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4246 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4247 TREE_TYPE (huge_cst
), huge_cst
);
4250 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4251 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4252 tmp
, build_int_cst (type
, 1));
4254 gfc_add_modify (&se
->pre
, limit
, tmp
);
4256 /* Walk the arguments. */
4257 actual
= expr
->value
.function
.actual
;
4258 arrayexpr
= actual
->expr
;
4259 arrayss
= gfc_walk_expr (arrayexpr
);
4260 gcc_assert (arrayss
!= gfc_ss_terminator
);
4262 actual
= actual
->next
->next
;
4263 gcc_assert (actual
);
4264 maskexpr
= actual
->expr
;
4266 if (maskexpr
&& maskexpr
->rank
!= 0)
4268 maskss
= gfc_walk_expr (maskexpr
);
4269 gcc_assert (maskss
!= gfc_ss_terminator
);
4274 if (gfc_array_size (arrayexpr
, &asize
))
4276 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4278 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4279 boolean_type_node
, nonempty
,
4280 gfc_index_zero_node
);
4285 /* Initialize the scalarizer. */
4286 gfc_init_loopinfo (&loop
);
4287 gfc_add_ss_to_loop (&loop
, arrayss
);
4289 gfc_add_ss_to_loop (&loop
, maskss
);
4291 /* Initialize the loop. */
4292 gfc_conv_ss_startstride (&loop
);
4294 /* The code generated can have more than one loop in sequence (see the
4295 comment at the function header). This doesn't work well with the
4296 scalarizer, which changes arrays' offset when the scalarization loops
4297 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4298 are currently inlined in the scalar case only. As there is no dependency
4299 to care about in that case, there is no temporary, so that we can use the
4300 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4301 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4302 gfc_trans_scalarized_loop_boundary even later to restore offset.
4303 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4304 should eventually go away. We could either create two loops properly,
4305 or find another way to save/restore the array offsets between the two
4306 loops (without conflicting with temporary management), or use a single
4307 loop minmaxval implementation. See PR 31067. */
4308 loop
.temp_dim
= loop
.dimen
;
4309 gfc_conv_loop_setup (&loop
, &expr
->where
);
4311 if (nonempty
== NULL
&& maskss
== NULL
4312 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
4313 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4314 loop
.from
[0], loop
.to
[0]);
4315 nonempty_var
= NULL
;
4316 if (nonempty
== NULL
4317 && (HONOR_INFINITIES (DECL_MODE (limit
))
4318 || HONOR_NANS (DECL_MODE (limit
))))
4320 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
4321 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
4322 nonempty
= nonempty_var
;
4326 if (HONOR_NANS (DECL_MODE (limit
)))
4328 if (loop
.dimen
== 1)
4330 lab
= gfc_build_label_decl (NULL_TREE
);
4331 TREE_USED (lab
) = 1;
4335 fast
= gfc_create_var (boolean_type_node
, "fast");
4336 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
4340 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
4342 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
4343 /* Generate the loop body. */
4344 gfc_start_scalarized_body (&loop
, &body
);
4346 /* If we have a mask, only add this element if the mask is set. */
4349 gfc_init_se (&maskse
, NULL
);
4350 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4352 gfc_conv_expr_val (&maskse
, maskexpr
);
4353 gfc_add_block_to_block (&body
, &maskse
.pre
);
4355 gfc_start_block (&block
);
4358 gfc_init_block (&block
);
4360 /* Compare with the current limit. */
4361 gfc_init_se (&arrayse
, NULL
);
4362 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4363 arrayse
.ss
= arrayss
;
4364 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4365 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4367 gfc_init_block (&block2
);
4370 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
4372 if (HONOR_NANS (DECL_MODE (limit
)))
4374 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4375 boolean_type_node
, arrayse
.expr
, limit
);
4377 ifbody
= build1_v (GOTO_EXPR
, lab
);
4380 stmtblock_t ifblock
;
4382 gfc_init_block (&ifblock
);
4383 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4384 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
4385 ifbody
= gfc_finish_block (&ifblock
);
4387 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4388 build_empty_stmt (input_location
));
4389 gfc_add_expr_to_block (&block2
, tmp
);
4393 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4395 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4397 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4398 arrayse
.expr
, limit
);
4399 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4400 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4401 build_empty_stmt (input_location
));
4402 gfc_add_expr_to_block (&block2
, tmp
);
4406 tmp
= fold_build2_loc (input_location
,
4407 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4408 type
, arrayse
.expr
, limit
);
4409 gfc_add_modify (&block2
, limit
, tmp
);
4415 tree elsebody
= gfc_finish_block (&block2
);
4417 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4419 if (HONOR_NANS (DECL_MODE (limit
))
4420 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4422 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4423 arrayse
.expr
, limit
);
4424 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4425 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
4426 build_empty_stmt (input_location
));
4430 tmp
= fold_build2_loc (input_location
,
4431 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4432 type
, arrayse
.expr
, limit
);
4433 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4435 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
4436 gfc_add_expr_to_block (&block
, tmp
);
4439 gfc_add_block_to_block (&block
, &block2
);
4441 gfc_add_block_to_block (&block
, &arrayse
.post
);
4443 tmp
= gfc_finish_block (&block
);
4445 /* We enclose the above in if (mask) {...}. */
4446 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4447 build_empty_stmt (input_location
));
4448 gfc_add_expr_to_block (&body
, tmp
);
4452 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4454 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4456 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4457 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4459 /* If we have a mask, only add this element if the mask is set. */
4462 gfc_init_se (&maskse
, NULL
);
4463 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4465 gfc_conv_expr_val (&maskse
, maskexpr
);
4466 gfc_add_block_to_block (&body
, &maskse
.pre
);
4468 gfc_start_block (&block
);
4471 gfc_init_block (&block
);
4473 /* Compare with the current limit. */
4474 gfc_init_se (&arrayse
, NULL
);
4475 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4476 arrayse
.ss
= arrayss
;
4477 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4478 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4480 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4482 if (HONOR_NANS (DECL_MODE (limit
))
4483 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4485 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4486 arrayse
.expr
, limit
);
4487 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4488 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4489 build_empty_stmt (input_location
));
4490 gfc_add_expr_to_block (&block
, tmp
);
4494 tmp
= fold_build2_loc (input_location
,
4495 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4496 type
, arrayse
.expr
, limit
);
4497 gfc_add_modify (&block
, limit
, tmp
);
4500 gfc_add_block_to_block (&block
, &arrayse
.post
);
4502 tmp
= gfc_finish_block (&block
);
4504 /* We enclose the above in if (mask) {...}. */
4505 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4506 build_empty_stmt (input_location
));
4507 gfc_add_expr_to_block (&body
, tmp
);
4508 /* Avoid initializing loopvar[0] again, it should be left where
4509 it finished by the first loop. */
4510 loop
.from
[0] = loop
.loopvar
[0];
4512 gfc_trans_scalarizing_loops (&loop
, &body
);
4516 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4518 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4519 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4521 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4523 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4525 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4527 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4530 /* For a scalar mask, enclose the loop in an if statement. */
4531 if (maskexpr
&& maskss
== NULL
)
4535 gfc_init_se (&maskse
, NULL
);
4536 gfc_conv_expr_val (&maskse
, maskexpr
);
4537 gfc_init_block (&block
);
4538 gfc_add_block_to_block (&block
, &loop
.pre
);
4539 gfc_add_block_to_block (&block
, &loop
.post
);
4540 tmp
= gfc_finish_block (&block
);
4542 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4543 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4545 else_stmt
= build_empty_stmt (input_location
);
4546 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4547 gfc_add_expr_to_block (&block
, tmp
);
4548 gfc_add_block_to_block (&se
->pre
, &block
);
4552 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4553 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4556 gfc_cleanup_loop (&loop
);
4561 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4563 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4569 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4570 type
= TREE_TYPE (args
[0]);
4572 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4573 build_int_cst (type
, 1), args
[1]);
4574 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4575 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4576 build_int_cst (type
, 0));
4577 type
= gfc_typenode_for_spec (&expr
->ts
);
4578 se
->expr
= convert (type
, tmp
);
4582 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4584 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4588 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4590 /* Convert both arguments to the unsigned type of the same size. */
4591 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4592 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4594 /* If they have unequal type size, convert to the larger one. */
4595 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4596 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4597 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4598 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4599 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4600 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4602 /* Now, we compare them. */
4603 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4608 /* Generate code to perform the specified operation. */
4610 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4614 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4615 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4621 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4625 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4626 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4627 TREE_TYPE (arg
), arg
);
4630 /* Set or clear a single bit. */
4632 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4639 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4640 type
= TREE_TYPE (args
[0]);
4642 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4643 build_int_cst (type
, 1), args
[1]);
4649 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4651 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4654 /* Extract a sequence of bits.
4655 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4657 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4664 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4665 type
= TREE_TYPE (args
[0]);
4667 mask
= build_int_cst (type
, -1);
4668 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4669 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4671 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4673 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4677 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4680 tree args
[2], type
, num_bits
, cond
;
4682 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4684 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4685 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4686 type
= TREE_TYPE (args
[0]);
4689 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4691 gcc_assert (right_shift
);
4693 se
->expr
= fold_build2_loc (input_location
,
4694 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4695 TREE_TYPE (args
[0]), args
[0], args
[1]);
4698 se
->expr
= fold_convert (type
, se
->expr
);
4700 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4701 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4703 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4704 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4707 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4708 build_int_cst (type
, 0), se
->expr
);
4711 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4713 : ((shift >= 0) ? i << shift : i >> -shift)
4714 where all shifts are logical shifts. */
4716 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4728 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4730 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4731 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4733 type
= TREE_TYPE (args
[0]);
4734 utype
= unsigned_type_for (type
);
4736 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4739 /* Left shift if positive. */
4740 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4742 /* Right shift if negative.
4743 We convert to an unsigned type because we want a logical shift.
4744 The standard doesn't define the case of shifting negative
4745 numbers, and we try to be compatible with other compilers, most
4746 notably g77, here. */
4747 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4748 utype
, convert (utype
, args
[0]), width
));
4750 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4751 build_int_cst (TREE_TYPE (args
[1]), 0));
4752 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4754 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4755 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4757 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4758 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4760 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4761 build_int_cst (type
, 0), tmp
);
4765 /* Circular shift. AKA rotate or barrel shift. */
4768 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4776 unsigned int num_args
;
4778 num_args
= gfc_intrinsic_argument_list_length (expr
);
4779 args
= XALLOCAVEC (tree
, num_args
);
4781 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4785 /* Use a library function for the 3 parameter version. */
4786 tree int4type
= gfc_get_int_type (4);
4788 type
= TREE_TYPE (args
[0]);
4789 /* We convert the first argument to at least 4 bytes, and
4790 convert back afterwards. This removes the need for library
4791 functions for all argument sizes, and function will be
4792 aligned to at least 32 bits, so there's no loss. */
4793 if (expr
->ts
.kind
< 4)
4794 args
[0] = convert (int4type
, args
[0]);
4796 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4797 need loads of library functions. They cannot have values >
4798 BIT_SIZE (I) so the conversion is safe. */
4799 args
[1] = convert (int4type
, args
[1]);
4800 args
[2] = convert (int4type
, args
[2]);
4802 switch (expr
->ts
.kind
)
4807 tmp
= gfor_fndecl_math_ishftc4
;
4810 tmp
= gfor_fndecl_math_ishftc8
;
4813 tmp
= gfor_fndecl_math_ishftc16
;
4818 se
->expr
= build_call_expr_loc (input_location
,
4819 tmp
, 3, args
[0], args
[1], args
[2]);
4820 /* Convert the result back to the original type, if we extended
4821 the first argument's width above. */
4822 if (expr
->ts
.kind
< 4)
4823 se
->expr
= convert (type
, se
->expr
);
4827 type
= TREE_TYPE (args
[0]);
4829 /* Evaluate arguments only once. */
4830 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4831 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4833 /* Rotate left if positive. */
4834 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4836 /* Rotate right if negative. */
4837 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4839 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4841 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4842 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4844 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4846 /* Do nothing if shift == 0. */
4847 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4849 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4854 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4855 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4857 The conditional expression is necessary because the result of LEADZ(0)
4858 is defined, but the result of __builtin_clz(0) is undefined for most
4861 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4862 difference in bit size between the argument of LEADZ and the C int. */
4865 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4877 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4878 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4880 /* Which variant of __builtin_clz* should we call? */
4881 if (argsize
<= INT_TYPE_SIZE
)
4883 arg_type
= unsigned_type_node
;
4884 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4886 else if (argsize
<= LONG_TYPE_SIZE
)
4888 arg_type
= long_unsigned_type_node
;
4889 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4891 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4893 arg_type
= long_long_unsigned_type_node
;
4894 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4898 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4899 arg_type
= gfc_build_uint_type (argsize
);
4903 /* Convert the actual argument twice: first, to the unsigned type of the
4904 same size; then, to the proper argument type for the built-in
4905 function. But the return type is of the default INTEGER kind. */
4906 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4907 arg
= fold_convert (arg_type
, arg
);
4908 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4909 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4911 /* Compute LEADZ for the case i .ne. 0. */
4914 s
= TYPE_PRECISION (arg_type
) - argsize
;
4915 tmp
= fold_convert (result_type
,
4916 build_call_expr_loc (input_location
, func
,
4918 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4919 tmp
, build_int_cst (result_type
, s
));
4923 /* We end up here if the argument type is larger than 'long long'.
4924 We generate this code:
4926 if (x & (ULL_MAX << ULL_SIZE) != 0)
4927 return clzll ((unsigned long long) (x >> ULLSIZE));
4929 return ULL_SIZE + clzll ((unsigned long long) x);
4930 where ULL_MAX is the largest value that a ULL_MAX can hold
4931 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4932 is the bit-size of the long long type (64 in this example). */
4933 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4935 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4936 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4937 long_long_unsigned_type_node
,
4938 build_int_cst (long_long_unsigned_type_node
,
4941 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4942 fold_convert (arg_type
, ullmax
), ullsize
);
4943 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4945 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4946 cond
, build_int_cst (arg_type
, 0));
4948 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4950 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4951 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4952 tmp1
= fold_convert (result_type
,
4953 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4955 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4956 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4957 tmp2
= fold_convert (result_type
,
4958 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4959 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4962 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4966 /* Build BIT_SIZE. */
4967 bit_size
= build_int_cst (result_type
, argsize
);
4969 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4970 arg
, build_int_cst (arg_type
, 0));
4971 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4976 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4978 The conditional expression is necessary because the result of TRAILZ(0)
4979 is defined, but the result of __builtin_ctz(0) is undefined for most
4983 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4994 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4995 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4997 /* Which variant of __builtin_ctz* should we call? */
4998 if (argsize
<= INT_TYPE_SIZE
)
5000 arg_type
= unsigned_type_node
;
5001 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5003 else if (argsize
<= LONG_TYPE_SIZE
)
5005 arg_type
= long_unsigned_type_node
;
5006 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5008 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5010 arg_type
= long_long_unsigned_type_node
;
5011 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5015 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5016 arg_type
= gfc_build_uint_type (argsize
);
5020 /* Convert the actual argument twice: first, to the unsigned type of the
5021 same size; then, to the proper argument type for the built-in
5022 function. But the return type is of the default INTEGER kind. */
5023 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5024 arg
= fold_convert (arg_type
, arg
);
5025 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5026 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5028 /* Compute TRAILZ for the case i .ne. 0. */
5030 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5034 /* We end up here if the argument type is larger than 'long long'.
5035 We generate this code:
5037 if ((x & ULL_MAX) == 0)
5038 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5040 return ctzll ((unsigned long long) x);
5042 where ULL_MAX is the largest value that a ULL_MAX can hold
5043 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5044 is the bit-size of the long long type (64 in this example). */
5045 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5047 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5048 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5049 long_long_unsigned_type_node
,
5050 build_int_cst (long_long_unsigned_type_node
, 0));
5052 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5053 fold_convert (arg_type
, ullmax
));
5054 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5055 build_int_cst (arg_type
, 0));
5057 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5059 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5060 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5061 tmp1
= fold_convert (result_type
,
5062 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5063 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5066 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5067 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5068 tmp2
= fold_convert (result_type
,
5069 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5071 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5075 /* Build BIT_SIZE. */
5076 bit_size
= build_int_cst (result_type
, argsize
);
5078 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5079 arg
, build_int_cst (arg_type
, 0));
5080 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5084 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5085 for types larger than "long long", we call the long long built-in for
5086 the lower and higher bits and combine the result. */
5089 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5097 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5098 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5099 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5101 /* Which variant of the builtin should we call? */
5102 if (argsize
<= INT_TYPE_SIZE
)
5104 arg_type
= unsigned_type_node
;
5105 func
= builtin_decl_explicit (parity
5107 : BUILT_IN_POPCOUNT
);
5109 else if (argsize
<= LONG_TYPE_SIZE
)
5111 arg_type
= long_unsigned_type_node
;
5112 func
= builtin_decl_explicit (parity
5114 : BUILT_IN_POPCOUNTL
);
5116 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5118 arg_type
= long_long_unsigned_type_node
;
5119 func
= builtin_decl_explicit (parity
5121 : BUILT_IN_POPCOUNTLL
);
5125 /* Our argument type is larger than 'long long', which mean none
5126 of the POPCOUNT builtins covers it. We thus call the 'long long'
5127 variant multiple times, and add the results. */
5128 tree utype
, arg2
, call1
, call2
;
5130 /* For now, we only cover the case where argsize is twice as large
5132 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5134 func
= builtin_decl_explicit (parity
5136 : BUILT_IN_POPCOUNTLL
);
5138 /* Convert it to an integer, and store into a variable. */
5139 utype
= gfc_build_uint_type (argsize
);
5140 arg
= fold_convert (utype
, arg
);
5141 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5143 /* Call the builtin twice. */
5144 call1
= build_call_expr_loc (input_location
, func
, 1,
5145 fold_convert (long_long_unsigned_type_node
,
5148 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5149 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5150 call2
= build_call_expr_loc (input_location
, func
, 1,
5151 fold_convert (long_long_unsigned_type_node
,
5154 /* Combine the results. */
5156 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5159 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5165 /* Convert the actual argument twice: first, to the unsigned type of the
5166 same size; then, to the proper argument type for the built-in
5168 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5169 arg
= fold_convert (arg_type
, arg
);
5171 se
->expr
= fold_convert (result_type
,
5172 build_call_expr_loc (input_location
, func
, 1, arg
));
5176 /* Process an intrinsic with unspecified argument-types that has an optional
5177 argument (which could be of type character), e.g. EOSHIFT. For those, we
5178 need to append the string length of the optional argument if it is not
5179 present and the type is really character.
5180 primary specifies the position (starting at 1) of the non-optional argument
5181 specifying the type and optional gives the position of the optional
5182 argument in the arglist. */
5185 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5186 unsigned primary
, unsigned optional
)
5188 gfc_actual_arglist
* prim_arg
;
5189 gfc_actual_arglist
* opt_arg
;
5191 gfc_actual_arglist
* arg
;
5193 vec
<tree
, va_gc
> *append_args
;
5195 /* Find the two arguments given as position. */
5199 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5203 if (cur_pos
== primary
)
5205 if (cur_pos
== optional
)
5208 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5211 gcc_assert (prim_arg
);
5212 gcc_assert (prim_arg
->expr
);
5213 gcc_assert (opt_arg
);
5215 /* If we do have type CHARACTER and the optional argument is really absent,
5216 append a dummy 0 as string length. */
5218 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5222 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5223 vec_alloc (append_args
, 1);
5224 append_args
->quick_push (dummy
);
5227 /* Build the call itself. */
5228 gcc_assert (!se
->ignore_optional
);
5229 sym
= gfc_get_symbol_for_expr (expr
, false);
5230 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5232 gfc_free_symbol (sym
);
5236 /* The length of a character string. */
5238 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5247 gcc_assert (!se
->ss
);
5249 arg
= expr
->value
.function
.actual
->expr
;
5251 type
= gfc_typenode_for_spec (&expr
->ts
);
5252 switch (arg
->expr_type
)
5255 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5259 /* Obtain the string length from the function used by
5260 trans-array.c(gfc_trans_array_constructor). */
5262 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5266 if (arg
->ref
== NULL
5267 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
5269 /* This doesn't catch all cases.
5270 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5271 and the surrounding thread. */
5272 sym
= arg
->symtree
->n
.sym
;
5273 decl
= gfc_get_symbol_decl (sym
);
5274 if (decl
== current_function_decl
&& sym
->attr
.function
5275 && (sym
->result
== sym
))
5276 decl
= gfc_get_fake_result_decl (sym
, 0);
5278 len
= sym
->ts
.u
.cl
->backend_decl
;
5283 /* Otherwise fall through. */
5286 /* Anybody stupid enough to do this deserves inefficient code. */
5287 gfc_init_se (&argse
, se
);
5289 gfc_conv_expr (&argse
, arg
);
5291 gfc_conv_expr_descriptor (&argse
, arg
);
5292 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5293 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5294 len
= argse
.string_length
;
5297 se
->expr
= convert (type
, len
);
5300 /* The length of a character string not including trailing blanks. */
5302 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
5304 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5305 tree args
[2], type
, fndecl
;
5307 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5308 type
= gfc_typenode_for_spec (&expr
->ts
);
5311 fndecl
= gfor_fndecl_string_len_trim
;
5313 fndecl
= gfor_fndecl_string_len_trim_char4
;
5317 se
->expr
= build_call_expr_loc (input_location
,
5318 fndecl
, 2, args
[0], args
[1]);
5319 se
->expr
= convert (type
, se
->expr
);
5323 /* Returns the starting position of a substring within a string. */
5326 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
5329 tree logical4_type_node
= gfc_get_logical_type (4);
5333 unsigned int num_args
;
5335 args
= XALLOCAVEC (tree
, 5);
5337 /* Get number of arguments; characters count double due to the
5338 string length argument. Kind= is not passed to the library
5339 and thus ignored. */
5340 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
5345 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5346 type
= gfc_typenode_for_spec (&expr
->ts
);
5349 args
[4] = build_int_cst (logical4_type_node
, 0);
5351 args
[4] = convert (logical4_type_node
, args
[4]);
5353 fndecl
= build_addr (function
);
5354 se
->expr
= build_call_array_loc (input_location
,
5355 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5357 se
->expr
= convert (type
, se
->expr
);
5361 /* The ascii value for a single character. */
5363 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
5365 tree args
[3], type
, pchartype
;
5368 nargs
= gfc_intrinsic_argument_list_length (expr
);
5369 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
5370 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
5371 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
5372 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
5373 type
= gfc_typenode_for_spec (&expr
->ts
);
5375 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5377 se
->expr
= convert (type
, se
->expr
);
5381 /* Intrinsic ISNAN calls __builtin_isnan. */
5384 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
5388 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5389 se
->expr
= build_call_expr_loc (input_location
,
5390 builtin_decl_explicit (BUILT_IN_ISNAN
),
5392 STRIP_TYPE_NOPS (se
->expr
);
5393 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5397 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5398 their argument against a constant integer value. */
5401 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
5405 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5406 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
5407 gfc_typenode_for_spec (&expr
->ts
),
5408 arg
, build_int_cst (TREE_TYPE (arg
), value
));
5413 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5416 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
5424 unsigned int num_args
;
5426 num_args
= gfc_intrinsic_argument_list_length (expr
);
5427 args
= XALLOCAVEC (tree
, num_args
);
5429 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5430 if (expr
->ts
.type
!= BT_CHARACTER
)
5438 /* We do the same as in the non-character case, but the argument
5439 list is different because of the string length arguments. We
5440 also have to set the string length for the result. */
5447 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5449 se
->string_length
= len
;
5451 type
= TREE_TYPE (tsource
);
5452 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5453 fold_convert (type
, fsource
));
5457 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5460 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5462 tree args
[3], mask
, type
;
5464 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5465 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5467 type
= TREE_TYPE (args
[0]);
5468 gcc_assert (TREE_TYPE (args
[1]) == type
);
5469 gcc_assert (TREE_TYPE (mask
) == type
);
5471 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5472 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5473 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5475 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5480 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5481 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5484 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5486 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5489 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5490 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5492 type
= gfc_get_int_type (expr
->ts
.kind
);
5493 utype
= unsigned_type_for (type
);
5495 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5496 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5498 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5499 build_int_cst (utype
, 0));
5503 /* Left-justified mask. */
5504 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5506 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5507 fold_convert (utype
, res
));
5509 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5510 smaller than type width. */
5511 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5512 build_int_cst (TREE_TYPE (arg
), 0));
5513 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5514 build_int_cst (utype
, 0), res
);
5518 /* Right-justified mask. */
5519 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5520 fold_convert (utype
, arg
));
5521 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5523 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5524 strictly smaller than type width. */
5525 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5527 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5528 cond
, allones
, res
);
5531 se
->expr
= fold_convert (type
, res
);
5535 /* FRACTION (s) is translated into:
5536 isfinite (s) ? frexp (s, &dummy_int) : NaN */
5538 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5540 tree arg
, type
, tmp
, res
, frexp
, cond
;
5542 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5544 type
= gfc_typenode_for_spec (&expr
->ts
);
5545 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5546 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5548 cond
= build_call_expr_loc (input_location
,
5549 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5552 tmp
= gfc_create_var (integer_type_node
, NULL
);
5553 res
= build_call_expr_loc (input_location
, frexp
, 2,
5554 fold_convert (type
, arg
),
5555 gfc_build_addr_expr (NULL_TREE
, tmp
));
5556 res
= fold_convert (type
, res
);
5558 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5559 cond
, res
, gfc_build_nan (type
, ""));
5563 /* NEAREST (s, dir) is translated into
5564 tmp = copysign (HUGE_VAL, dir);
5565 return nextafter (s, tmp);
5568 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5570 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5572 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5573 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5575 type
= gfc_typenode_for_spec (&expr
->ts
);
5576 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5578 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5579 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5580 fold_convert (type
, args
[1]));
5581 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5582 fold_convert (type
, args
[0]), tmp
);
5583 se
->expr
= fold_convert (type
, se
->expr
);
5587 /* SPACING (s) is translated into
5597 e = MAX_EXPR (e, emin);
5598 res = scalbn (1., e);
5602 where prec is the precision of s, gfc_real_kinds[k].digits,
5603 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5604 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5607 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5609 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5610 tree cond
, nan
, tmp
, frexp
, scalbn
;
5614 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5615 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5616 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5617 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5619 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5620 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5622 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5623 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5625 type
= gfc_typenode_for_spec (&expr
->ts
);
5626 e
= gfc_create_var (integer_type_node
, NULL
);
5627 res
= gfc_create_var (type
, NULL
);
5630 /* Build the block for s /= 0. */
5631 gfc_start_block (&block
);
5632 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5633 gfc_build_addr_expr (NULL_TREE
, e
));
5634 gfc_add_expr_to_block (&block
, tmp
);
5636 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5638 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5639 integer_type_node
, tmp
, emin
));
5641 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5642 build_real_from_int_cst (type
, integer_one_node
), e
);
5643 gfc_add_modify (&block
, res
, tmp
);
5645 /* Finish by building the IF statement for value zero. */
5646 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5647 build_real_from_int_cst (type
, integer_zero_node
));
5648 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5649 gfc_finish_block (&block
));
5651 /* And deal with infinities and NaNs. */
5652 cond
= build_call_expr_loc (input_location
,
5653 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5655 nan
= gfc_build_nan (type
, "");
5656 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
5658 gfc_add_expr_to_block (&se
->pre
, tmp
);
5663 /* RRSPACING (s) is translated into
5672 x = scalbn (x, precision - e);
5679 where precision is gfc_real_kinds[k].digits. */
5682 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5684 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5688 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5689 prec
= gfc_real_kinds
[k
].digits
;
5691 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5692 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5693 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5695 type
= gfc_typenode_for_spec (&expr
->ts
);
5696 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5697 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5699 e
= gfc_create_var (integer_type_node
, NULL
);
5700 x
= gfc_create_var (type
, NULL
);
5701 gfc_add_modify (&se
->pre
, x
,
5702 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5705 gfc_start_block (&block
);
5706 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5707 gfc_build_addr_expr (NULL_TREE
, e
));
5708 gfc_add_expr_to_block (&block
, tmp
);
5710 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5711 build_int_cst (integer_type_node
, prec
), e
);
5712 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5713 gfc_add_modify (&block
, x
, tmp
);
5714 stmt
= gfc_finish_block (&block
);
5717 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5718 build_real_from_int_cst (type
, integer_zero_node
));
5719 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5721 /* And deal with infinities and NaNs. */
5722 cond
= build_call_expr_loc (input_location
,
5723 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5725 nan
= gfc_build_nan (type
, "");
5726 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
5728 gfc_add_expr_to_block (&se
->pre
, tmp
);
5729 se
->expr
= fold_convert (type
, x
);
5733 /* SCALE (s, i) is translated into scalbn (s, i). */
5735 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5737 tree args
[2], type
, scalbn
;
5739 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5741 type
= gfc_typenode_for_spec (&expr
->ts
);
5742 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5743 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5744 fold_convert (type
, args
[0]),
5745 fold_convert (integer_type_node
, args
[1]));
5746 se
->expr
= fold_convert (type
, se
->expr
);
5750 /* SET_EXPONENT (s, i) is translated into
5751 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
5753 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5755 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
5757 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5758 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5760 type
= gfc_typenode_for_spec (&expr
->ts
);
5761 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5762 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5764 tmp
= gfc_create_var (integer_type_node
, NULL
);
5765 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5766 fold_convert (type
, args
[0]),
5767 gfc_build_addr_expr (NULL_TREE
, tmp
));
5768 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5769 fold_convert (integer_type_node
, args
[1]));
5770 res
= fold_convert (type
, res
);
5772 /* Call to isfinite */
5773 cond
= build_call_expr_loc (input_location
,
5774 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5776 nan
= gfc_build_nan (type
, "");
5778 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5784 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5786 gfc_actual_arglist
*actual
;
5793 gfc_init_se (&argse
, NULL
);
5794 actual
= expr
->value
.function
.actual
;
5796 if (actual
->expr
->ts
.type
== BT_CLASS
)
5797 gfc_add_class_array_ref (actual
->expr
);
5799 argse
.want_pointer
= 1;
5800 argse
.data_not_needed
= 1;
5801 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5802 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5803 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5804 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5806 /* Build the call to size0. */
5807 fncall0
= build_call_expr_loc (input_location
,
5808 gfor_fndecl_size0
, 1, arg1
);
5810 actual
= actual
->next
;
5814 gfc_init_se (&argse
, NULL
);
5815 gfc_conv_expr_type (&argse
, actual
->expr
,
5816 gfc_array_index_type
);
5817 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5819 /* Unusually, for an intrinsic, size does not exclude
5820 an optional arg2, so we must test for it. */
5821 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5822 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5823 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5826 /* Build the call to size1. */
5827 fncall1
= build_call_expr_loc (input_location
,
5828 gfor_fndecl_size1
, 2,
5831 gfc_init_se (&argse
, NULL
);
5832 argse
.want_pointer
= 1;
5833 argse
.data_not_needed
= 1;
5834 gfc_conv_expr (&argse
, actual
->expr
);
5835 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5836 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5837 argse
.expr
, null_pointer_node
);
5838 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5839 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5840 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5844 se
->expr
= NULL_TREE
;
5845 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5846 gfc_array_index_type
,
5847 argse
.expr
, gfc_index_one_node
);
5850 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5852 argse
.expr
= gfc_index_zero_node
;
5853 se
->expr
= NULL_TREE
;
5858 if (se
->expr
== NULL_TREE
)
5860 tree ubound
, lbound
;
5862 arg1
= build_fold_indirect_ref_loc (input_location
,
5864 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5865 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5866 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5867 gfc_array_index_type
, ubound
, lbound
);
5868 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5869 gfc_array_index_type
,
5870 se
->expr
, gfc_index_one_node
);
5871 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5872 gfc_array_index_type
, se
->expr
,
5873 gfc_index_zero_node
);
5876 type
= gfc_typenode_for_spec (&expr
->ts
);
5877 se
->expr
= convert (type
, se
->expr
);
5881 /* Helper function to compute the size of a character variable,
5882 excluding the terminating null characters. The result has
5883 gfc_array_index_type type. */
5886 size_of_string_in_bytes (int kind
, tree string_length
)
5889 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5891 bytesize
= build_int_cst (gfc_array_index_type
,
5892 gfc_character_kinds
[i
].bit_size
/ 8);
5894 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5896 fold_convert (gfc_array_index_type
, string_length
));
5901 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5912 gfc_init_se (&argse
, NULL
);
5913 arg
= expr
->value
.function
.actual
->expr
;
5915 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
5916 gfc_conv_expr_descriptor (&argse
, arg
);
5918 gfc_conv_expr_reference (&argse
, arg
);
5920 if (arg
->ts
.type
== BT_ASSUMED
)
5922 /* This only works if an array descriptor has been passed; thus, extract
5923 the size from the descriptor. */
5924 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
5925 == TYPE_PRECISION (size_type_node
));
5926 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
5927 tmp
= DECL_LANG_SPECIFIC (tmp
)
5928 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
5929 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
5930 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
5931 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5932 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
5933 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
5934 build_int_cst (TREE_TYPE (tmp
),
5935 GFC_DTYPE_SIZE_SHIFT
));
5936 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
5938 else if (arg
->ts
.type
== BT_CLASS
)
5940 /* Conv_expr_descriptor returns a component_ref to _data component of the
5941 class object. The class object may be a non-pointer object, e.g.
5942 located on the stack, or a memory location pointed to, e.g. a
5943 parameter, i.e., an indirect_ref. */
5945 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
5946 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
5947 && GFC_DECL_CLASS (TREE_OPERAND (
5948 TREE_OPERAND (argse
.expr
, 0), 0)))
5949 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
5950 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
5951 else if (arg
->rank
> 0)
5952 /* The scalarizer added an additional temp. To get the class' vptr
5953 one has to look at the original backend_decl. */
5954 byte_size
= gfc_class_vtab_size_get (
5955 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
5957 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
5961 if (arg
->ts
.type
== BT_CHARACTER
)
5962 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5966 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5969 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5970 byte_size
= fold_convert (gfc_array_index_type
,
5971 size_in_bytes (byte_size
));
5976 se
->expr
= byte_size
;
5979 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5980 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
5982 if (arg
->rank
== -1)
5984 tree cond
, loop_var
, exit_label
;
5987 tmp
= fold_convert (gfc_array_index_type
,
5988 gfc_conv_descriptor_rank (argse
.expr
));
5989 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
5990 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
5991 exit_label
= gfc_build_label_decl (NULL_TREE
);
5998 source_bytes = source_bytes * array.dim[i].extent;
6002 gfc_start_block (&body
);
6003 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6005 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6006 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6007 cond
, tmp
, build_empty_stmt (input_location
));
6008 gfc_add_expr_to_block (&body
, tmp
);
6010 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6011 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6012 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6013 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6014 gfc_array_index_type
, tmp
, source_bytes
);
6015 gfc_add_modify (&body
, source_bytes
, tmp
);
6017 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6018 gfc_array_index_type
, loop_var
,
6019 gfc_index_one_node
);
6020 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6022 tmp
= gfc_finish_block (&body
);
6024 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6026 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6028 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6029 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6033 /* Obtain the size of the array in bytes. */
6034 for (n
= 0; n
< arg
->rank
; n
++)
6037 idx
= gfc_rank_cst
[n
];
6038 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6039 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6040 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6041 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6042 gfc_array_index_type
, tmp
, source_bytes
);
6043 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6046 se
->expr
= source_bytes
;
6049 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6054 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6058 tree type
, result_type
, tmp
;
6060 arg
= expr
->value
.function
.actual
->expr
;
6062 gfc_init_se (&argse
, NULL
);
6063 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6067 if (arg
->ts
.type
== BT_CLASS
)
6069 gfc_add_vptr_component (arg
);
6070 gfc_add_size_component (arg
);
6071 gfc_conv_expr (&argse
, arg
);
6072 tmp
= fold_convert (result_type
, argse
.expr
);
6076 gfc_conv_expr_reference (&argse
, arg
);
6077 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6082 argse
.want_pointer
= 0;
6083 gfc_conv_expr_descriptor (&argse
, arg
);
6084 if (arg
->ts
.type
== BT_CLASS
)
6087 tmp
= gfc_class_vtab_size_get (
6088 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6090 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6091 tmp
= fold_convert (result_type
, tmp
);
6094 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6097 /* Obtain the argument's word length. */
6098 if (arg
->ts
.type
== BT_CHARACTER
)
6099 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6101 tmp
= size_in_bytes (type
);
6102 tmp
= fold_convert (result_type
, tmp
);
6105 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6106 build_int_cst (result_type
, BITS_PER_UNIT
));
6107 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6111 /* Intrinsic string comparison functions. */
6114 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6118 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6121 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6122 expr
->value
.function
.actual
->expr
->ts
.kind
,
6124 se
->expr
= fold_build2_loc (input_location
, op
,
6125 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6126 build_int_cst (TREE_TYPE (se
->expr
), 0));
6129 /* Generate a call to the adjustl/adjustr library function. */
6131 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6139 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6142 type
= TREE_TYPE (args
[2]);
6143 var
= gfc_conv_string_tmp (se
, type
, len
);
6146 tmp
= build_call_expr_loc (input_location
,
6147 fndecl
, 3, args
[0], args
[1], args
[2]);
6148 gfc_add_expr_to_block (&se
->pre
, tmp
);
6150 se
->string_length
= len
;
6154 /* Generate code for the TRANSFER intrinsic:
6156 DEST = TRANSFER (SOURCE, MOLD)
6158 typeof<DEST> = typeof<MOLD>
6163 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6165 typeof<DEST> = typeof<MOLD>
6167 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6168 sizeof (DEST(0) * SIZE). */
6170 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6186 gfc_actual_arglist
*arg
;
6188 gfc_array_info
*info
;
6192 gfc_expr
*source_expr
, *mold_expr
;
6196 info
= &se
->ss
->info
->data
.array
;
6198 /* Convert SOURCE. The output from this stage is:-
6199 source_bytes = length of the source in bytes
6200 source = pointer to the source data. */
6201 arg
= expr
->value
.function
.actual
;
6202 source_expr
= arg
->expr
;
6204 /* Ensure double transfer through LOGICAL preserves all
6206 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6207 && arg
->expr
->value
.function
.esym
== NULL
6208 && arg
->expr
->value
.function
.isym
!= NULL
6209 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6210 && arg
->expr
->ts
.type
== BT_LOGICAL
6211 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6212 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6214 gfc_init_se (&argse
, NULL
);
6216 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6218 /* Obtain the pointer to source and the length of source in bytes. */
6219 if (arg
->expr
->rank
== 0)
6221 gfc_conv_expr_reference (&argse
, arg
->expr
);
6222 if (arg
->expr
->ts
.type
== BT_CLASS
)
6223 source
= gfc_class_data_get (argse
.expr
);
6225 source
= argse
.expr
;
6227 /* Obtain the source word length. */
6228 switch (arg
->expr
->ts
.type
)
6231 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6232 argse
.string_length
);
6235 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6238 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6240 tmp
= fold_convert (gfc_array_index_type
,
6241 size_in_bytes (source_type
));
6247 argse
.want_pointer
= 0;
6248 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6249 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6250 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6252 /* Repack the source if not simply contiguous. */
6253 if (!gfc_is_simply_contiguous (arg
->expr
, false))
6255 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6257 if (warn_array_temporaries
)
6258 gfc_warning (OPT_Warray_temporaries
,
6259 "Creating array temporary at %L", &expr
->where
);
6261 source
= build_call_expr_loc (input_location
,
6262 gfor_fndecl_in_pack
, 1, tmp
);
6263 source
= gfc_evaluate_now (source
, &argse
.pre
);
6265 /* Free the temporary. */
6266 gfc_start_block (&block
);
6267 tmp
= gfc_call_free (source
);
6268 gfc_add_expr_to_block (&block
, tmp
);
6269 stmt
= gfc_finish_block (&block
);
6271 /* Clean up if it was repacked. */
6272 gfc_init_block (&block
);
6273 tmp
= gfc_conv_array_data (argse
.expr
);
6274 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6276 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6277 build_empty_stmt (input_location
));
6278 gfc_add_expr_to_block (&block
, tmp
);
6279 gfc_add_block_to_block (&block
, &se
->post
);
6280 gfc_init_block (&se
->post
);
6281 gfc_add_block_to_block (&se
->post
, &block
);
6284 /* Obtain the source word length. */
6285 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6286 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6287 argse
.string_length
);
6289 tmp
= fold_convert (gfc_array_index_type
,
6290 size_in_bytes (source_type
));
6292 /* Obtain the size of the array in bytes. */
6293 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6294 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6297 idx
= gfc_rank_cst
[n
];
6298 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6299 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6300 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6301 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6302 gfc_array_index_type
, upper
, lower
);
6303 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6304 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6305 gfc_array_index_type
, extent
,
6306 gfc_index_one_node
);
6307 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6308 gfc_array_index_type
, tmp
, source_bytes
);
6312 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6313 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6314 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6316 /* Now convert MOLD. The outputs are:
6317 mold_type = the TREE type of MOLD
6318 dest_word_len = destination word length in bytes. */
6320 mold_expr
= arg
->expr
;
6322 gfc_init_se (&argse
, NULL
);
6324 scalar_mold
= arg
->expr
->rank
== 0;
6326 if (arg
->expr
->rank
== 0)
6328 gfc_conv_expr_reference (&argse
, arg
->expr
);
6329 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6334 gfc_init_se (&argse
, NULL
);
6335 argse
.want_pointer
= 0;
6336 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6337 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6340 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6341 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6343 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6345 /* If this TRANSFER is nested in another TRANSFER, use a type
6346 that preserves all bits. */
6347 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6348 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6351 /* Obtain the destination word length. */
6352 switch (arg
->expr
->ts
.type
)
6355 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6356 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6359 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6362 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6365 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6366 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6368 /* Finally convert SIZE, if it is present. */
6370 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6374 gfc_init_se (&argse
, NULL
);
6375 gfc_conv_expr_reference (&argse
, arg
->expr
);
6376 tmp
= convert (gfc_array_index_type
,
6377 build_fold_indirect_ref_loc (input_location
,
6379 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6380 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6385 /* Separate array and scalar results. */
6386 if (scalar_mold
&& tmp
== NULL_TREE
)
6387 goto scalar_transfer
;
6389 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6390 if (tmp
!= NULL_TREE
)
6391 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6392 tmp
, dest_word_len
);
6396 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6397 gfc_add_modify (&se
->pre
, size_words
,
6398 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6399 gfc_array_index_type
,
6400 size_bytes
, dest_word_len
));
6402 /* Evaluate the bounds of the result. If the loop range exists, we have
6403 to check if it is too large. If so, we modify loop->to be consistent
6404 with min(size, size(source)). Otherwise, size is made consistent with
6405 the loop range, so that the right number of bytes is transferred.*/
6406 n
= se
->loop
->order
[0];
6407 if (se
->loop
->to
[n
] != NULL_TREE
)
6409 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6410 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6411 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6412 tmp
, gfc_index_one_node
);
6413 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6415 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6416 gfc_add_modify (&se
->pre
, size_bytes
,
6417 fold_build2_loc (input_location
, MULT_EXPR
,
6418 gfc_array_index_type
,
6419 size_words
, dest_word_len
));
6420 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6421 size_words
, se
->loop
->from
[n
]);
6422 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6423 upper
, gfc_index_one_node
);
6427 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6428 size_words
, gfc_index_one_node
);
6429 se
->loop
->from
[n
] = gfc_index_zero_node
;
6432 se
->loop
->to
[n
] = upper
;
6434 /* Build a destination descriptor, using the pointer, source, as the
6436 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6437 NULL_TREE
, false, true, false, &expr
->where
);
6439 /* Cast the pointer to the result. */
6440 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6441 tmp
= fold_convert (pvoid_type_node
, tmp
);
6443 /* Use memcpy to do the transfer. */
6445 = build_call_expr_loc (input_location
,
6446 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6447 fold_convert (pvoid_type_node
, source
),
6448 fold_convert (size_type_node
,
6449 fold_build2_loc (input_location
,
6451 gfc_array_index_type
,
6454 gfc_add_expr_to_block (&se
->pre
, tmp
);
6456 se
->expr
= info
->descriptor
;
6457 if (expr
->ts
.type
== BT_CHARACTER
)
6458 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6462 /* Deal with scalar results. */
6464 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6465 dest_word_len
, source_bytes
);
6466 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6467 extent
, gfc_index_zero_node
);
6469 if (expr
->ts
.type
== BT_CHARACTER
)
6471 tree direct
, indirect
, free
;
6473 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6474 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6477 /* If source is longer than the destination, use a pointer to
6478 the source directly. */
6479 gfc_init_block (&block
);
6480 gfc_add_modify (&block
, tmpdecl
, ptr
);
6481 direct
= gfc_finish_block (&block
);
6483 /* Otherwise, allocate a string with the length of the destination
6484 and copy the source into it. */
6485 gfc_init_block (&block
);
6486 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6487 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6488 gfc_add_modify (&block
, tmpdecl
,
6489 fold_convert (TREE_TYPE (ptr
), tmp
));
6490 tmp
= build_call_expr_loc (input_location
,
6491 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6492 fold_convert (pvoid_type_node
, tmpdecl
),
6493 fold_convert (pvoid_type_node
, ptr
),
6494 fold_convert (size_type_node
, extent
));
6495 gfc_add_expr_to_block (&block
, tmp
);
6496 indirect
= gfc_finish_block (&block
);
6498 /* Wrap it up with the condition. */
6499 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6500 dest_word_len
, source_bytes
);
6501 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6502 gfc_add_expr_to_block (&se
->pre
, tmp
);
6504 /* Free the temporary string, if necessary. */
6505 free
= gfc_call_free (tmpdecl
);
6506 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6507 dest_word_len
, source_bytes
);
6508 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6509 gfc_add_expr_to_block (&se
->post
, tmp
);
6512 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6516 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6518 ptr
= convert (build_pointer_type (mold_type
), source
);
6520 /* For CLASS results, allocate the needed memory first. */
6521 if (mold_expr
->ts
.type
== BT_CLASS
)
6524 cdata
= gfc_class_data_get (tmpdecl
);
6525 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6526 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6529 /* Use memcpy to do the transfer. */
6530 if (mold_expr
->ts
.type
== BT_CLASS
)
6531 tmp
= gfc_class_data_get (tmpdecl
);
6533 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6535 tmp
= build_call_expr_loc (input_location
,
6536 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6537 fold_convert (pvoid_type_node
, tmp
),
6538 fold_convert (pvoid_type_node
, ptr
),
6539 fold_convert (size_type_node
, extent
));
6540 gfc_add_expr_to_block (&se
->pre
, tmp
);
6542 /* For CLASS results, set the _vptr. */
6543 if (mold_expr
->ts
.type
== BT_CLASS
)
6547 vptr
= gfc_class_vptr_get (tmpdecl
);
6548 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6550 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6551 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6559 /* Generate code for the ALLOCATED intrinsic.
6560 Generate inline code that directly check the address of the argument. */
6563 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6565 gfc_actual_arglist
*arg1
;
6569 gfc_init_se (&arg1se
, NULL
);
6570 arg1
= expr
->value
.function
.actual
;
6572 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6574 /* Make sure that class array expressions have both a _data
6575 component reference and an array reference.... */
6576 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6577 gfc_add_class_array_ref (arg1
->expr
);
6578 /* .... whilst scalars only need the _data component. */
6580 gfc_add_data_component (arg1
->expr
);
6583 if (arg1
->expr
->rank
== 0)
6585 /* Allocatable scalar. */
6586 arg1se
.want_pointer
= 1;
6587 gfc_conv_expr (&arg1se
, arg1
->expr
);
6592 /* Allocatable array. */
6593 arg1se
.descriptor_only
= 1;
6594 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6595 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6598 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6599 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6600 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6604 /* Generate code for the ASSOCIATED intrinsic.
6605 If both POINTER and TARGET are arrays, generate a call to library function
6606 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6607 In other cases, generate inline code that directly compare the address of
6608 POINTER with the address of TARGET. */
6611 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6613 gfc_actual_arglist
*arg1
;
6614 gfc_actual_arglist
*arg2
;
6619 tree nonzero_charlen
;
6620 tree nonzero_arraylen
;
6624 gfc_init_se (&arg1se
, NULL
);
6625 gfc_init_se (&arg2se
, NULL
);
6626 arg1
= expr
->value
.function
.actual
;
6629 /* Check whether the expression is a scalar or not; we cannot use
6630 arg1->expr->rank as it can be nonzero for proc pointers. */
6631 ss
= gfc_walk_expr (arg1
->expr
);
6632 scalar
= ss
== gfc_ss_terminator
;
6634 gfc_free_ss_chain (ss
);
6638 /* No optional target. */
6641 /* A pointer to a scalar. */
6642 arg1se
.want_pointer
= 1;
6643 gfc_conv_expr (&arg1se
, arg1
->expr
);
6644 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6645 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6646 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6648 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6650 tmp2
= gfc_class_data_get (arg1se
.expr
);
6651 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6652 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6659 /* A pointer to an array. */
6660 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6661 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6663 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6664 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6665 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6666 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6671 /* An optional target. */
6672 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6673 gfc_add_data_component (arg2
->expr
);
6675 nonzero_charlen
= NULL_TREE
;
6676 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6677 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6679 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6683 /* A pointer to a scalar. */
6684 arg1se
.want_pointer
= 1;
6685 gfc_conv_expr (&arg1se
, arg1
->expr
);
6686 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6687 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6688 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6690 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6691 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6693 arg2se
.want_pointer
= 1;
6694 gfc_conv_expr (&arg2se
, arg2
->expr
);
6695 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6696 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6697 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6699 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6700 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6701 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6702 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6703 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6704 arg1se
.expr
, arg2se
.expr
);
6705 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6706 arg1se
.expr
, null_pointer_node
);
6707 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6708 boolean_type_node
, tmp
, tmp2
);
6712 /* An array pointer of zero length is not associated if target is
6714 arg1se
.descriptor_only
= 1;
6715 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6716 if (arg1
->expr
->rank
== -1)
6718 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6719 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6720 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6723 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6724 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6725 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6726 boolean_type_node
, tmp
,
6727 build_int_cst (TREE_TYPE (tmp
), 0));
6729 /* A pointer to an array, call library function _gfor_associated. */
6730 arg1se
.want_pointer
= 1;
6731 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6733 arg2se
.want_pointer
= 1;
6734 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6735 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6736 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6737 se
->expr
= build_call_expr_loc (input_location
,
6738 gfor_fndecl_associated
, 2,
6739 arg1se
.expr
, arg2se
.expr
);
6740 se
->expr
= convert (boolean_type_node
, se
->expr
);
6741 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6742 boolean_type_node
, se
->expr
,
6746 /* If target is present zero character length pointers cannot
6748 if (nonzero_charlen
!= NULL_TREE
)
6749 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6751 se
->expr
, nonzero_charlen
);
6754 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6758 /* Generate code for the SAME_TYPE_AS intrinsic.
6759 Generate inline code that directly checks the vindices. */
6762 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6767 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6769 gfc_init_se (&se1
, NULL
);
6770 gfc_init_se (&se2
, NULL
);
6772 a
= expr
->value
.function
.actual
->expr
;
6773 b
= expr
->value
.function
.actual
->next
->expr
;
6775 if (UNLIMITED_POLY (a
))
6777 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6778 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6779 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6782 if (UNLIMITED_POLY (b
))
6784 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6785 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6786 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6789 if (a
->ts
.type
== BT_CLASS
)
6791 gfc_add_vptr_component (a
);
6792 gfc_add_hash_component (a
);
6794 else if (a
->ts
.type
== BT_DERIVED
)
6795 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6796 a
->ts
.u
.derived
->hash_value
);
6798 if (b
->ts
.type
== BT_CLASS
)
6800 gfc_add_vptr_component (b
);
6801 gfc_add_hash_component (b
);
6803 else if (b
->ts
.type
== BT_DERIVED
)
6804 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6805 b
->ts
.u
.derived
->hash_value
);
6807 gfc_conv_expr (&se1
, a
);
6808 gfc_conv_expr (&se2
, b
);
6810 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6811 boolean_type_node
, se1
.expr
,
6812 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6815 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6816 boolean_type_node
, conda
, tmp
);
6819 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6820 boolean_type_node
, condb
, tmp
);
6822 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6826 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6829 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6833 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6834 se
->expr
= build_call_expr_loc (input_location
,
6835 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6836 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6840 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6843 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6847 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6849 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6850 type
= gfc_get_int_type (4);
6851 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6853 /* Convert it to the required type. */
6854 type
= gfc_typenode_for_spec (&expr
->ts
);
6855 se
->expr
= build_call_expr_loc (input_location
,
6856 gfor_fndecl_si_kind
, 1, arg
);
6857 se
->expr
= fold_convert (type
, se
->expr
);
6861 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6864 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6866 gfc_actual_arglist
*actual
;
6869 vec
<tree
, va_gc
> *args
= NULL
;
6871 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6873 gfc_init_se (&argse
, se
);
6875 /* Pass a NULL pointer for an absent arg. */
6876 if (actual
->expr
== NULL
)
6877 argse
.expr
= null_pointer_node
;
6883 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6885 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6886 ts
.type
= BT_INTEGER
;
6887 ts
.kind
= gfc_c_int_kind
;
6888 gfc_convert_type (actual
->expr
, &ts
, 2);
6890 gfc_conv_expr_reference (&argse
, actual
->expr
);
6893 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6894 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6895 vec_safe_push (args
, argse
.expr
);
6898 /* Convert it to the required type. */
6899 type
= gfc_typenode_for_spec (&expr
->ts
);
6900 se
->expr
= build_call_expr_loc_vec (input_location
,
6901 gfor_fndecl_sr_kind
, args
);
6902 se
->expr
= fold_convert (type
, se
->expr
);
6906 /* Generate code for TRIM (A) intrinsic function. */
6909 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6919 unsigned int num_args
;
6921 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6922 args
= XALLOCAVEC (tree
, num_args
);
6924 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6925 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6926 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6928 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6929 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6932 if (expr
->ts
.kind
== 1)
6933 function
= gfor_fndecl_string_trim
;
6934 else if (expr
->ts
.kind
== 4)
6935 function
= gfor_fndecl_string_trim_char4
;
6939 fndecl
= build_addr (function
);
6940 tmp
= build_call_array_loc (input_location
,
6941 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6943 gfc_add_expr_to_block (&se
->pre
, tmp
);
6945 /* Free the temporary afterwards, if necessary. */
6946 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6947 len
, build_int_cst (TREE_TYPE (len
), 0));
6948 tmp
= gfc_call_free (var
);
6949 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6950 gfc_add_expr_to_block (&se
->post
, tmp
);
6953 se
->string_length
= len
;
6957 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6960 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6962 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6963 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6965 stmtblock_t block
, body
;
6968 /* We store in charsize the size of a character. */
6969 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6970 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6972 /* Get the arguments. */
6973 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6974 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6976 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6977 ncopies_type
= TREE_TYPE (ncopies
);
6979 /* Check that NCOPIES is not negative. */
6980 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6981 build_int_cst (ncopies_type
, 0));
6982 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6983 "Argument NCOPIES of REPEAT intrinsic is negative "
6984 "(its value is %ld)",
6985 fold_convert (long_integer_type_node
, ncopies
));
6987 /* If the source length is zero, any non negative value of NCOPIES
6988 is valid, and nothing happens. */
6989 n
= gfc_create_var (ncopies_type
, "ncopies");
6990 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6991 build_int_cst (size_type_node
, 0));
6992 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6993 build_int_cst (ncopies_type
, 0), ncopies
);
6994 gfc_add_modify (&se
->pre
, n
, tmp
);
6997 /* Check that ncopies is not too large: ncopies should be less than
6998 (or equal to) MAX / slen, where MAX is the maximal integer of
6999 the gfc_charlen_type_node type. If slen == 0, we need a special
7000 case to avoid the division by zero. */
7001 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
7002 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
7003 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
7004 fold_convert (size_type_node
, max
), slen
);
7005 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7006 ? size_type_node
: ncopies_type
;
7007 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7008 fold_convert (largest
, ncopies
),
7009 fold_convert (largest
, max
));
7010 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7011 build_int_cst (size_type_node
, 0));
7012 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7013 boolean_false_node
, cond
);
7014 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7015 "Argument NCOPIES of REPEAT intrinsic is too large");
7017 /* Compute the destination length. */
7018 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7019 fold_convert (gfc_charlen_type_node
, slen
),
7020 fold_convert (gfc_charlen_type_node
, ncopies
));
7021 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7022 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7024 /* Generate the code to do the repeat operation:
7025 for (i = 0; i < ncopies; i++)
7026 memmove (dest + (i * slen * size), src, slen*size); */
7027 gfc_start_block (&block
);
7028 count
= gfc_create_var (ncopies_type
, "count");
7029 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7030 exit_label
= gfc_build_label_decl (NULL_TREE
);
7032 /* Start the loop body. */
7033 gfc_start_block (&body
);
7035 /* Exit the loop if count >= ncopies. */
7036 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7038 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7039 TREE_USED (exit_label
) = 1;
7040 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7041 build_empty_stmt (input_location
));
7042 gfc_add_expr_to_block (&body
, tmp
);
7044 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7045 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7046 fold_convert (gfc_charlen_type_node
, slen
),
7047 fold_convert (gfc_charlen_type_node
, count
));
7048 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7049 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7050 tmp
= fold_build_pointer_plus_loc (input_location
,
7051 fold_convert (pvoid_type_node
, dest
), tmp
);
7052 tmp
= build_call_expr_loc (input_location
,
7053 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7055 fold_build2_loc (input_location
, MULT_EXPR
,
7056 size_type_node
, slen
,
7057 fold_convert (size_type_node
,
7059 gfc_add_expr_to_block (&body
, tmp
);
7061 /* Increment count. */
7062 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7063 count
, build_int_cst (TREE_TYPE (count
), 1));
7064 gfc_add_modify (&body
, count
, tmp
);
7066 /* Build the loop. */
7067 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7068 gfc_add_expr_to_block (&block
, tmp
);
7070 /* Add the exit label. */
7071 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7072 gfc_add_expr_to_block (&block
, tmp
);
7074 /* Finish the block. */
7075 tmp
= gfc_finish_block (&block
);
7076 gfc_add_expr_to_block (&se
->pre
, tmp
);
7078 /* Set the result value. */
7080 se
->string_length
= dlen
;
7084 /* Generate code for the IARGC intrinsic. */
7087 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7093 /* Call the library function. This always returns an INTEGER(4). */
7094 fndecl
= gfor_fndecl_iargc
;
7095 tmp
= build_call_expr_loc (input_location
,
7098 /* Convert it to the required type. */
7099 type
= gfc_typenode_for_spec (&expr
->ts
);
7100 tmp
= fold_convert (type
, tmp
);
7106 /* The loc intrinsic returns the address of its argument as
7107 gfc_index_integer_kind integer. */
7110 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7115 gcc_assert (!se
->ss
);
7117 arg_expr
= expr
->value
.function
.actual
->expr
;
7118 if (arg_expr
->rank
== 0)
7120 if (arg_expr
->ts
.type
== BT_CLASS
)
7121 gfc_add_component_ref (arg_expr
, "_data");
7122 gfc_conv_expr_reference (se
, arg_expr
);
7125 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7126 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7128 /* Create a temporary variable for loc return value. Without this,
7129 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7130 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7131 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7132 se
->expr
= temp_var
;
7136 /* The following routine generates code for the intrinsic
7137 functions from the ISO_C_BINDING module:
7143 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7145 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7147 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7149 if (arg
->expr
->rank
== 0)
7150 gfc_conv_expr_reference (se
, arg
->expr
);
7151 else if (gfc_is_simply_contiguous (arg
->expr
, false))
7152 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7155 gfc_conv_expr_descriptor (se
, arg
->expr
);
7156 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7159 /* TODO -- the following two lines shouldn't be necessary, but if
7160 they're removed, a bug is exposed later in the code path.
7161 This workaround was thus introduced, but will have to be
7162 removed; please see PR 35150 for details about the issue. */
7163 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7164 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7166 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7167 gfc_conv_expr_reference (se
, arg
->expr
);
7168 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7173 /* Build the addr_expr for the first argument. The argument is
7174 already an *address* so we don't need to set want_pointer in
7176 gfc_init_se (&arg1se
, NULL
);
7177 gfc_conv_expr (&arg1se
, arg
->expr
);
7178 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7179 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7181 /* See if we were given two arguments. */
7182 if (arg
->next
->expr
== NULL
)
7183 /* Only given one arg so generate a null and do a
7184 not-equal comparison against the first arg. */
7185 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7187 fold_convert (TREE_TYPE (arg1se
.expr
),
7188 null_pointer_node
));
7194 /* Given two arguments so build the arg2se from second arg. */
7195 gfc_init_se (&arg2se
, NULL
);
7196 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7197 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7198 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7200 /* Generate test to compare that the two args are equal. */
7201 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7202 arg1se
.expr
, arg2se
.expr
);
7203 /* Generate test to ensure that the first arg is not null. */
7204 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7206 arg1se
.expr
, null_pointer_node
);
7208 /* Finally, the generated test must check that both arg1 is not
7209 NULL and that it is equal to the second arg. */
7210 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7212 not_null_expr
, eq_expr
);
7220 /* The following routine generates code for the intrinsic
7221 subroutines from the ISO_C_BINDING module:
7223 * C_F_PROCPOINTER. */
7226 conv_isocbinding_subroutine (gfc_code
*code
)
7233 tree desc
, dim
, tmp
, stride
, offset
;
7234 stmtblock_t body
, block
;
7236 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7238 gfc_init_se (&se
, NULL
);
7239 gfc_init_se (&cptrse
, NULL
);
7240 gfc_conv_expr (&cptrse
, arg
->expr
);
7241 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7242 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7244 gfc_init_se (&fptrse
, NULL
);
7245 if (arg
->next
->expr
->rank
== 0)
7247 fptrse
.want_pointer
= 1;
7248 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7249 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7250 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7251 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7252 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7253 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7255 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7256 TREE_TYPE (fptrse
.expr
),
7258 fold_convert (TREE_TYPE (fptrse
.expr
),
7260 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7261 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7262 return gfc_finish_block (&se
.pre
);
7265 gfc_start_block (&block
);
7267 /* Get the descriptor of the Fortran pointer. */
7268 fptrse
.descriptor_only
= 1;
7269 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7270 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7273 /* Set data value, dtype, and offset. */
7274 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7275 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7276 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7277 gfc_get_dtype (TREE_TYPE (desc
)));
7279 /* Start scalarization of the bounds, using the shape argument. */
7281 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7282 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7283 gfc_init_se (&shapese
, NULL
);
7285 gfc_init_loopinfo (&loop
);
7286 gfc_add_ss_to_loop (&loop
, shape_ss
);
7287 gfc_conv_ss_startstride (&loop
);
7288 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7289 gfc_mark_ss_chain_used (shape_ss
, 1);
7291 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7292 shapese
.ss
= shape_ss
;
7294 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7295 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7296 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7297 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7300 gfc_start_scalarized_body (&loop
, &body
);
7302 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7303 loop
.loopvar
[0], loop
.from
[0]);
7305 /* Set bounds and stride. */
7306 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7307 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7309 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7310 gfc_add_block_to_block (&body
, &shapese
.pre
);
7311 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7312 gfc_add_block_to_block (&body
, &shapese
.post
);
7314 /* Calculate offset. */
7315 gfc_add_modify (&body
, offset
,
7316 fold_build2_loc (input_location
, PLUS_EXPR
,
7317 gfc_array_index_type
, offset
, stride
));
7318 /* Update stride. */
7319 gfc_add_modify (&body
, stride
,
7320 fold_build2_loc (input_location
, MULT_EXPR
,
7321 gfc_array_index_type
, stride
,
7322 fold_convert (gfc_array_index_type
,
7324 /* Finish scalarization loop. */
7325 gfc_trans_scalarizing_loops (&loop
, &body
);
7326 gfc_add_block_to_block (&block
, &loop
.pre
);
7327 gfc_add_block_to_block (&block
, &loop
.post
);
7328 gfc_add_block_to_block (&block
, &fptrse
.post
);
7329 gfc_cleanup_loop (&loop
);
7331 gfc_add_modify (&block
, offset
,
7332 fold_build1_loc (input_location
, NEGATE_EXPR
,
7333 gfc_array_index_type
, offset
));
7334 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7336 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7337 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7338 return gfc_finish_block (&se
.pre
);
7342 /* Save and restore floating-point state. */
7345 gfc_save_fp_state (stmtblock_t
*block
)
7347 tree type
, fpstate
, tmp
;
7349 type
= build_array_type (char_type_node
,
7350 build_range_type (size_type_node
, size_zero_node
,
7351 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
7352 fpstate
= gfc_create_var (type
, "fpstate");
7353 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
7355 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
7357 gfc_add_expr_to_block (block
, tmp
);
7364 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
7368 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
7370 gfc_add_expr_to_block (block
, tmp
);
7374 /* Generate code for arguments of IEEE functions. */
7377 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
7380 gfc_actual_arglist
*actual
;
7385 actual
= expr
->value
.function
.actual
;
7386 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
7388 gcc_assert (actual
);
7391 gfc_init_se (&argse
, se
);
7392 gfc_conv_expr_val (&argse
, e
);
7394 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7395 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7396 argarray
[arg
] = argse
.expr
;
7401 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7402 and IEEE_UNORDERED, which translate directly to GCC type-generic
7406 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
7407 enum built_in_function code
, int nargs
)
7410 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
7412 conv_ieee_function_args (se
, expr
, args
, nargs
);
7413 se
->expr
= build_call_expr_loc_array (input_location
,
7414 builtin_decl_explicit (code
),
7416 STRIP_TYPE_NOPS (se
->expr
);
7417 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7421 /* Generate code for IEEE_IS_NORMAL intrinsic:
7422 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7425 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
7427 tree arg
, isnormal
, iszero
;
7429 /* Convert arg, evaluate it only once. */
7430 conv_ieee_function_args (se
, expr
, &arg
, 1);
7431 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7433 isnormal
= build_call_expr_loc (input_location
,
7434 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
7436 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
7437 build_real_from_int_cst (TREE_TYPE (arg
),
7438 integer_zero_node
));
7439 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7440 boolean_type_node
, isnormal
, iszero
);
7441 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7445 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7446 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7449 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
7451 tree arg
, signbit
, isnan
;
7453 /* Convert arg, evaluate it only once. */
7454 conv_ieee_function_args (se
, expr
, &arg
, 1);
7455 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7457 isnan
= build_call_expr_loc (input_location
,
7458 builtin_decl_explicit (BUILT_IN_ISNAN
),
7460 STRIP_TYPE_NOPS (isnan
);
7462 signbit
= build_call_expr_loc (input_location
,
7463 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7465 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7466 signbit
, integer_zero_node
);
7468 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7469 boolean_type_node
, signbit
,
7470 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
7471 TREE_TYPE(isnan
), isnan
));
7473 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7477 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7480 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
7481 enum built_in_function code
)
7483 tree arg
, decl
, call
, fpstate
;
7486 conv_ieee_function_args (se
, expr
, &arg
, 1);
7487 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7488 decl
= builtin_decl_for_precision (code
, argprec
);
7490 /* Save floating-point state. */
7491 fpstate
= gfc_save_fp_state (&se
->pre
);
7493 /* Make the function call. */
7494 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7495 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
7497 /* Restore floating-point state. */
7498 gfc_restore_fp_state (&se
->post
, fpstate
);
7502 /* Generate code for IEEE_REM. */
7505 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
7507 tree args
[2], decl
, call
, fpstate
;
7510 conv_ieee_function_args (se
, expr
, args
, 2);
7512 /* If arguments have unequal size, convert them to the larger. */
7513 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
7514 > TYPE_PRECISION (TREE_TYPE (args
[1])))
7515 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7516 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
7517 > TYPE_PRECISION (TREE_TYPE (args
[0])))
7518 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
7520 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7521 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
7523 /* Save floating-point state. */
7524 fpstate
= gfc_save_fp_state (&se
->pre
);
7526 /* Make the function call. */
7527 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7528 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7530 /* Restore floating-point state. */
7531 gfc_restore_fp_state (&se
->post
, fpstate
);
7535 /* Generate code for IEEE_NEXT_AFTER. */
7538 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
7540 tree args
[2], decl
, call
, fpstate
;
7543 conv_ieee_function_args (se
, expr
, args
, 2);
7545 /* Result has the characteristics of first argument. */
7546 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7547 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7548 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
7550 /* Save floating-point state. */
7551 fpstate
= gfc_save_fp_state (&se
->pre
);
7553 /* Make the function call. */
7554 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7555 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7557 /* Restore floating-point state. */
7558 gfc_restore_fp_state (&se
->post
, fpstate
);
7562 /* Generate code for IEEE_SCALB. */
7565 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
7567 tree args
[2], decl
, call
, huge
, type
;
7570 conv_ieee_function_args (se
, expr
, args
, 2);
7572 /* Result has the characteristics of first argument. */
7573 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7574 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
7576 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
7578 /* We need to fold the integer into the range of a C int. */
7579 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7580 type
= TREE_TYPE (args
[1]);
7582 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
7583 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
7585 huge
= fold_convert (type
, huge
);
7586 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
7588 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
7589 fold_build1_loc (input_location
, NEGATE_EXPR
,
7593 args
[1] = fold_convert (integer_type_node
, args
[1]);
7595 /* Make the function call. */
7596 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7597 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7601 /* Generate code for IEEE_COPY_SIGN. */
7604 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
7606 tree args
[2], decl
, sign
;
7609 conv_ieee_function_args (se
, expr
, args
, 2);
7611 /* Get the sign of the second argument. */
7612 sign
= build_call_expr_loc (input_location
,
7613 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7615 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7616 sign
, integer_zero_node
);
7618 /* Create a value of one, with the right sign. */
7619 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
7621 fold_build1_loc (input_location
, NEGATE_EXPR
,
7625 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
7627 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7628 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
7630 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7634 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7638 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
7640 const char *name
= expr
->value
.function
.name
;
7642 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7644 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
7645 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
7646 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
7647 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
7648 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
7649 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
7650 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
7651 conv_intrinsic_ieee_is_normal (se
, expr
);
7652 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
7653 conv_intrinsic_ieee_is_negative (se
, expr
);
7654 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
7655 conv_intrinsic_ieee_copy_sign (se
, expr
);
7656 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
7657 conv_intrinsic_ieee_scalb (se
, expr
);
7658 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
7659 conv_intrinsic_ieee_next_after (se
, expr
);
7660 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
7661 conv_intrinsic_ieee_rem (se
, expr
);
7662 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
7663 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
7664 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
7665 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
7667 /* It is not among the functions we translate directly. We return
7668 false, so a library function call is emitted. */
7677 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
7680 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
7682 tree arg
, res
, restype
;
7684 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7685 arg
= fold_convert (size_type_node
, arg
);
7686 res
= build_call_expr_loc (input_location
,
7687 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
7688 restype
= gfc_typenode_for_spec (&expr
->ts
);
7689 se
->expr
= fold_convert (restype
, res
);
7693 /* Generate code for an intrinsic function. Some map directly to library
7694 calls, others get special handling. In some cases the name of the function
7695 used depends on the type specifiers. */
7698 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7704 name
= &expr
->value
.function
.name
[2];
7708 lib
= gfc_is_intrinsic_libcall (expr
);
7712 se
->ignore_optional
= 1;
7714 switch (expr
->value
.function
.isym
->id
)
7716 case GFC_ISYM_EOSHIFT
:
7718 case GFC_ISYM_RESHAPE
:
7719 /* For all of those the first argument specifies the type and the
7720 third is optional. */
7721 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7725 gfc_conv_intrinsic_funcall (se
, expr
);
7733 switch (expr
->value
.function
.isym
->id
)
7738 case GFC_ISYM_REPEAT
:
7739 gfc_conv_intrinsic_repeat (se
, expr
);
7743 gfc_conv_intrinsic_trim (se
, expr
);
7746 case GFC_ISYM_SC_KIND
:
7747 gfc_conv_intrinsic_sc_kind (se
, expr
);
7750 case GFC_ISYM_SI_KIND
:
7751 gfc_conv_intrinsic_si_kind (se
, expr
);
7754 case GFC_ISYM_SR_KIND
:
7755 gfc_conv_intrinsic_sr_kind (se
, expr
);
7758 case GFC_ISYM_EXPONENT
:
7759 gfc_conv_intrinsic_exponent (se
, expr
);
7763 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7765 fndecl
= gfor_fndecl_string_scan
;
7767 fndecl
= gfor_fndecl_string_scan_char4
;
7771 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7774 case GFC_ISYM_VERIFY
:
7775 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7777 fndecl
= gfor_fndecl_string_verify
;
7779 fndecl
= gfor_fndecl_string_verify_char4
;
7783 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7786 case GFC_ISYM_ALLOCATED
:
7787 gfc_conv_allocated (se
, expr
);
7790 case GFC_ISYM_ASSOCIATED
:
7791 gfc_conv_associated(se
, expr
);
7794 case GFC_ISYM_SAME_TYPE_AS
:
7795 gfc_conv_same_type_as (se
, expr
);
7799 gfc_conv_intrinsic_abs (se
, expr
);
7802 case GFC_ISYM_ADJUSTL
:
7803 if (expr
->ts
.kind
== 1)
7804 fndecl
= gfor_fndecl_adjustl
;
7805 else if (expr
->ts
.kind
== 4)
7806 fndecl
= gfor_fndecl_adjustl_char4
;
7810 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7813 case GFC_ISYM_ADJUSTR
:
7814 if (expr
->ts
.kind
== 1)
7815 fndecl
= gfor_fndecl_adjustr
;
7816 else if (expr
->ts
.kind
== 4)
7817 fndecl
= gfor_fndecl_adjustr_char4
;
7821 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7824 case GFC_ISYM_AIMAG
:
7825 gfc_conv_intrinsic_imagpart (se
, expr
);
7829 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7833 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7836 case GFC_ISYM_ANINT
:
7837 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7841 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7845 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7848 case GFC_ISYM_BTEST
:
7849 gfc_conv_intrinsic_btest (se
, expr
);
7853 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7857 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7861 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7865 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7868 case GFC_ISYM_C_ASSOCIATED
:
7869 case GFC_ISYM_C_FUNLOC
:
7870 case GFC_ISYM_C_LOC
:
7871 conv_isocbinding_function (se
, expr
);
7874 case GFC_ISYM_ACHAR
:
7876 gfc_conv_intrinsic_char (se
, expr
);
7879 case GFC_ISYM_CONVERSION
:
7881 case GFC_ISYM_LOGICAL
:
7883 gfc_conv_intrinsic_conversion (se
, expr
);
7886 /* Integer conversions are handled separately to make sure we get the
7887 correct rounding mode. */
7892 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7896 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7899 case GFC_ISYM_CEILING
:
7900 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7903 case GFC_ISYM_FLOOR
:
7904 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7908 gfc_conv_intrinsic_mod (se
, expr
, 0);
7911 case GFC_ISYM_MODULO
:
7912 gfc_conv_intrinsic_mod (se
, expr
, 1);
7915 case GFC_ISYM_CAF_GET
:
7916 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
);
7919 case GFC_ISYM_CMPLX
:
7920 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7923 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7924 gfc_conv_intrinsic_iargc (se
, expr
);
7927 case GFC_ISYM_COMPLEX
:
7928 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7931 case GFC_ISYM_CONJG
:
7932 gfc_conv_intrinsic_conjg (se
, expr
);
7935 case GFC_ISYM_COUNT
:
7936 gfc_conv_intrinsic_count (se
, expr
);
7939 case GFC_ISYM_CTIME
:
7940 gfc_conv_intrinsic_ctime (se
, expr
);
7944 gfc_conv_intrinsic_dim (se
, expr
);
7947 case GFC_ISYM_DOT_PRODUCT
:
7948 gfc_conv_intrinsic_dot_product (se
, expr
);
7951 case GFC_ISYM_DPROD
:
7952 gfc_conv_intrinsic_dprod (se
, expr
);
7955 case GFC_ISYM_DSHIFTL
:
7956 gfc_conv_intrinsic_dshift (se
, expr
, true);
7959 case GFC_ISYM_DSHIFTR
:
7960 gfc_conv_intrinsic_dshift (se
, expr
, false);
7963 case GFC_ISYM_FDATE
:
7964 gfc_conv_intrinsic_fdate (se
, expr
);
7967 case GFC_ISYM_FRACTION
:
7968 gfc_conv_intrinsic_fraction (se
, expr
);
7972 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7976 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7980 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
7983 case GFC_ISYM_IBCLR
:
7984 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
7987 case GFC_ISYM_IBITS
:
7988 gfc_conv_intrinsic_ibits (se
, expr
);
7991 case GFC_ISYM_IBSET
:
7992 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
7995 case GFC_ISYM_IACHAR
:
7996 case GFC_ISYM_ICHAR
:
7997 /* We assume ASCII character sequence. */
7998 gfc_conv_intrinsic_ichar (se
, expr
);
8001 case GFC_ISYM_IARGC
:
8002 gfc_conv_intrinsic_iargc (se
, expr
);
8006 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8009 case GFC_ISYM_INDEX
:
8010 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8012 fndecl
= gfor_fndecl_string_index
;
8014 fndecl
= gfor_fndecl_string_index_char4
;
8018 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8022 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8025 case GFC_ISYM_IPARITY
:
8026 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8029 case GFC_ISYM_IS_IOSTAT_END
:
8030 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8033 case GFC_ISYM_IS_IOSTAT_EOR
:
8034 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8037 case GFC_ISYM_ISNAN
:
8038 gfc_conv_intrinsic_isnan (se
, expr
);
8041 case GFC_ISYM_LSHIFT
:
8042 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8045 case GFC_ISYM_RSHIFT
:
8046 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8049 case GFC_ISYM_SHIFTA
:
8050 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8053 case GFC_ISYM_SHIFTL
:
8054 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8057 case GFC_ISYM_SHIFTR
:
8058 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8061 case GFC_ISYM_ISHFT
:
8062 gfc_conv_intrinsic_ishft (se
, expr
);
8065 case GFC_ISYM_ISHFTC
:
8066 gfc_conv_intrinsic_ishftc (se
, expr
);
8069 case GFC_ISYM_LEADZ
:
8070 gfc_conv_intrinsic_leadz (se
, expr
);
8073 case GFC_ISYM_TRAILZ
:
8074 gfc_conv_intrinsic_trailz (se
, expr
);
8077 case GFC_ISYM_POPCNT
:
8078 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8081 case GFC_ISYM_POPPAR
:
8082 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8085 case GFC_ISYM_LBOUND
:
8086 gfc_conv_intrinsic_bound (se
, expr
, 0);
8089 case GFC_ISYM_LCOBOUND
:
8090 conv_intrinsic_cobound (se
, expr
);
8093 case GFC_ISYM_TRANSPOSE
:
8094 /* The scalarizer has already been set up for reversed dimension access
8095 order ; now we just get the argument value normally. */
8096 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8100 gfc_conv_intrinsic_len (se
, expr
);
8103 case GFC_ISYM_LEN_TRIM
:
8104 gfc_conv_intrinsic_len_trim (se
, expr
);
8108 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8112 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8116 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8120 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8123 case GFC_ISYM_MALLOC
:
8124 gfc_conv_intrinsic_malloc (se
, expr
);
8127 case GFC_ISYM_MASKL
:
8128 gfc_conv_intrinsic_mask (se
, expr
, 1);
8131 case GFC_ISYM_MASKR
:
8132 gfc_conv_intrinsic_mask (se
, expr
, 0);
8136 if (expr
->ts
.type
== BT_CHARACTER
)
8137 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8139 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8142 case GFC_ISYM_MAXLOC
:
8143 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8146 case GFC_ISYM_MAXVAL
:
8147 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8150 case GFC_ISYM_MERGE
:
8151 gfc_conv_intrinsic_merge (se
, expr
);
8154 case GFC_ISYM_MERGE_BITS
:
8155 gfc_conv_intrinsic_merge_bits (se
, expr
);
8159 if (expr
->ts
.type
== BT_CHARACTER
)
8160 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8162 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8165 case GFC_ISYM_MINLOC
:
8166 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8169 case GFC_ISYM_MINVAL
:
8170 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8173 case GFC_ISYM_NEAREST
:
8174 gfc_conv_intrinsic_nearest (se
, expr
);
8177 case GFC_ISYM_NORM2
:
8178 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8182 gfc_conv_intrinsic_not (se
, expr
);
8186 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8189 case GFC_ISYM_PARITY
:
8190 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8193 case GFC_ISYM_PRESENT
:
8194 gfc_conv_intrinsic_present (se
, expr
);
8197 case GFC_ISYM_PRODUCT
:
8198 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8202 gfc_conv_intrinsic_rank (se
, expr
);
8205 case GFC_ISYM_RRSPACING
:
8206 gfc_conv_intrinsic_rrspacing (se
, expr
);
8209 case GFC_ISYM_SET_EXPONENT
:
8210 gfc_conv_intrinsic_set_exponent (se
, expr
);
8213 case GFC_ISYM_SCALE
:
8214 gfc_conv_intrinsic_scale (se
, expr
);
8218 gfc_conv_intrinsic_sign (se
, expr
);
8222 gfc_conv_intrinsic_size (se
, expr
);
8225 case GFC_ISYM_SIZEOF
:
8226 case GFC_ISYM_C_SIZEOF
:
8227 gfc_conv_intrinsic_sizeof (se
, expr
);
8230 case GFC_ISYM_STORAGE_SIZE
:
8231 gfc_conv_intrinsic_storage_size (se
, expr
);
8234 case GFC_ISYM_SPACING
:
8235 gfc_conv_intrinsic_spacing (se
, expr
);
8238 case GFC_ISYM_STRIDE
:
8239 conv_intrinsic_stride (se
, expr
);
8243 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8246 case GFC_ISYM_TRANSFER
:
8247 if (se
->ss
&& se
->ss
->info
->useflags
)
8248 /* Access the previously obtained result. */
8249 gfc_conv_tmp_array_ref (se
);
8251 gfc_conv_intrinsic_transfer (se
, expr
);
8254 case GFC_ISYM_TTYNAM
:
8255 gfc_conv_intrinsic_ttynam (se
, expr
);
8258 case GFC_ISYM_UBOUND
:
8259 gfc_conv_intrinsic_bound (se
, expr
, 1);
8262 case GFC_ISYM_UCOBOUND
:
8263 conv_intrinsic_cobound (se
, expr
);
8267 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8271 gfc_conv_intrinsic_loc (se
, expr
);
8274 case GFC_ISYM_THIS_IMAGE
:
8275 /* For num_images() == 1, handle as LCOBOUND. */
8276 if (expr
->value
.function
.actual
->expr
8277 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
8278 conv_intrinsic_cobound (se
, expr
);
8280 trans_this_image (se
, expr
);
8283 case GFC_ISYM_IMAGE_INDEX
:
8284 trans_image_index (se
, expr
);
8287 case GFC_ISYM_NUM_IMAGES
:
8288 trans_num_images (se
, expr
);
8291 case GFC_ISYM_ACCESS
:
8292 case GFC_ISYM_CHDIR
:
8293 case GFC_ISYM_CHMOD
:
8294 case GFC_ISYM_DTIME
:
8295 case GFC_ISYM_ETIME
:
8296 case GFC_ISYM_EXTENDS_TYPE_OF
:
8298 case GFC_ISYM_FGETC
:
8301 case GFC_ISYM_FPUTC
:
8302 case GFC_ISYM_FSTAT
:
8303 case GFC_ISYM_FTELL
:
8304 case GFC_ISYM_GETCWD
:
8305 case GFC_ISYM_GETGID
:
8306 case GFC_ISYM_GETPID
:
8307 case GFC_ISYM_GETUID
:
8308 case GFC_ISYM_HOSTNM
:
8310 case GFC_ISYM_IERRNO
:
8311 case GFC_ISYM_IRAND
:
8312 case GFC_ISYM_ISATTY
:
8315 case GFC_ISYM_LSTAT
:
8316 case GFC_ISYM_MATMUL
:
8317 case GFC_ISYM_MCLOCK
:
8318 case GFC_ISYM_MCLOCK8
:
8320 case GFC_ISYM_RENAME
:
8321 case GFC_ISYM_SECOND
:
8322 case GFC_ISYM_SECNDS
:
8323 case GFC_ISYM_SIGNAL
:
8325 case GFC_ISYM_SYMLNK
:
8326 case GFC_ISYM_SYSTEM
:
8328 case GFC_ISYM_TIME8
:
8329 case GFC_ISYM_UMASK
:
8330 case GFC_ISYM_UNLINK
:
8332 gfc_conv_intrinsic_funcall (se
, expr
);
8335 case GFC_ISYM_EOSHIFT
:
8337 case GFC_ISYM_RESHAPE
:
8338 /* For those, expr->rank should always be >0 and thus the if above the
8339 switch should have matched. */
8344 gfc_conv_intrinsic_lib_function (se
, expr
);
8351 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
8353 gfc_ss
*arg_ss
, *tmp_ss
;
8354 gfc_actual_arglist
*arg
;
8356 arg
= expr
->value
.function
.actual
;
8358 gcc_assert (arg
->expr
);
8360 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
8361 gcc_assert (arg_ss
!= gfc_ss_terminator
);
8363 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
8365 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
8366 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
8368 gcc_assert (tmp_ss
->dimen
== 2);
8370 /* We just invert dimensions. */
8371 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
8374 /* Stop when tmp_ss points to the last valid element of the chain... */
8375 if (tmp_ss
->next
== gfc_ss_terminator
)
8379 /* ... so that we can attach the rest of the chain to it. */
8386 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8387 This has the side effect of reversing the nested list, so there is no
8388 need to call gfc_reverse_ss on it (the given list is assumed not to be
8392 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8395 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8396 gfc_loopinfo
*new_loop
;
8398 gcc_assert (ss
!= gfc_ss_terminator
);
8400 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8402 new_ss
= gfc_get_ss ();
8403 new_ss
->next
= prev_ss
;
8404 new_ss
->parent
= ss
;
8405 new_ss
->info
= ss
->info
;
8406 new_ss
->info
->refcount
++;
8409 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8410 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8413 new_ss
->dim
[0] = ss
->dim
[dim
];
8415 gcc_assert (dim
< ss
->dimen
);
8417 ss_dim
= --ss
->dimen
;
8418 for (i
= dim
; i
< ss_dim
; i
++)
8419 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8421 ss
->dim
[ss_dim
] = 0;
8427 ss
->nested_ss
->parent
= new_ss
;
8428 new_ss
->nested_ss
= ss
->nested_ss
;
8430 ss
->nested_ss
= new_ss
;
8433 new_loop
= gfc_get_loopinfo ();
8434 gfc_init_loopinfo (new_loop
);
8436 gcc_assert (prev_ss
!= NULL
);
8437 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8438 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8439 return new_ss
->parent
;
8443 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8444 is to be inlined. */
8447 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8449 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8450 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8452 bool scalar_mask
= false;
8454 /* The rank of the result will be determined later. */
8455 arg1
= expr
->value
.function
.actual
;
8458 gcc_assert (arg3
!= NULL
);
8460 if (expr
->rank
== 0)
8463 tmp_ss
= gfc_ss_terminator
;
8469 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8470 if (mask_ss
== tmp_ss
)
8476 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8477 gcc_assert (array_ss
!= tmp_ss
);
8479 /* Odd thing: If the mask is scalar, it is used by the frontend after
8480 the array (to make an if around the nested loop). Thus it shall
8481 be after array_ss once the gfc_ss list is reversed. */
8483 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8487 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8489 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8490 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8498 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8501 switch (expr
->value
.function
.isym
->id
)
8503 case GFC_ISYM_PRODUCT
:
8505 return walk_inline_intrinsic_arith (ss
, expr
);
8507 case GFC_ISYM_TRANSPOSE
:
8508 return walk_inline_intrinsic_transpose (ss
, expr
);
8517 /* This generates code to execute before entering the scalarization loop.
8518 Currently does nothing. */
8521 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8523 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8525 case GFC_ISYM_UBOUND
:
8526 case GFC_ISYM_LBOUND
:
8527 case GFC_ISYM_UCOBOUND
:
8528 case GFC_ISYM_LCOBOUND
:
8529 case GFC_ISYM_THIS_IMAGE
:
8538 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8539 are expanded into code inside the scalarization loop. */
8542 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8544 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8545 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8547 /* The two argument version returns a scalar. */
8548 if (expr
->value
.function
.actual
->next
->expr
)
8551 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8555 /* Walk an intrinsic array libcall. */
8558 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8560 gcc_assert (expr
->rank
> 0);
8561 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8565 /* Return whether the function call expression EXPR will be expanded
8566 inline by gfc_conv_intrinsic_function. */
8569 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8571 gfc_actual_arglist
*args
;
8573 if (!expr
->value
.function
.isym
)
8576 switch (expr
->value
.function
.isym
->id
)
8578 case GFC_ISYM_PRODUCT
:
8580 /* Disable inline expansion if code size matters. */
8584 args
= expr
->value
.function
.actual
;
8585 /* We need to be able to subset the SUM argument at compile-time. */
8586 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8591 case GFC_ISYM_TRANSPOSE
:
8600 /* Returns nonzero if the specified intrinsic function call maps directly to
8601 an external library call. Should only be used for functions that return
8605 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8607 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8608 gcc_assert (expr
->rank
> 0);
8610 if (gfc_inline_intrinsic_function_p (expr
))
8613 switch (expr
->value
.function
.isym
->id
)
8617 case GFC_ISYM_COUNT
:
8621 case GFC_ISYM_IPARITY
:
8622 case GFC_ISYM_MATMUL
:
8623 case GFC_ISYM_MAXLOC
:
8624 case GFC_ISYM_MAXVAL
:
8625 case GFC_ISYM_MINLOC
:
8626 case GFC_ISYM_MINVAL
:
8627 case GFC_ISYM_NORM2
:
8628 case GFC_ISYM_PARITY
:
8629 case GFC_ISYM_PRODUCT
:
8631 case GFC_ISYM_SHAPE
:
8632 case GFC_ISYM_SPREAD
:
8634 /* Ignore absent optional parameters. */
8637 case GFC_ISYM_RESHAPE
:
8638 case GFC_ISYM_CSHIFT
:
8639 case GFC_ISYM_EOSHIFT
:
8641 case GFC_ISYM_UNPACK
:
8642 /* Pass absent optional parameters. */
8650 /* Walk an intrinsic function. */
8652 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8653 gfc_intrinsic_sym
* isym
)
8657 if (isym
->elemental
)
8658 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8659 NULL
, GFC_SS_SCALAR
);
8661 if (expr
->rank
== 0)
8664 if (gfc_inline_intrinsic_function_p (expr
))
8665 return walk_inline_intrinsic_function (ss
, expr
);
8667 if (gfc_is_intrinsic_libcall (expr
))
8668 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8670 /* Special cases. */
8673 case GFC_ISYM_LBOUND
:
8674 case GFC_ISYM_LCOBOUND
:
8675 case GFC_ISYM_UBOUND
:
8676 case GFC_ISYM_UCOBOUND
:
8677 case GFC_ISYM_THIS_IMAGE
:
8678 return gfc_walk_intrinsic_bound (ss
, expr
);
8680 case GFC_ISYM_TRANSFER
:
8681 case GFC_ISYM_CAF_GET
:
8682 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8685 /* This probably meant someone forgot to add an intrinsic to the above
8686 list(s) when they implemented it, or something's gone horribly
8694 conv_co_collective (gfc_code
*code
)
8697 stmtblock_t block
, post_block
;
8698 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8699 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
8701 gfc_start_block (&block
);
8702 gfc_init_block (&post_block
);
8704 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
8706 opr_expr
= code
->ext
.actual
->next
->expr
;
8707 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
8708 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8709 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
8714 image_idx_expr
= code
->ext
.actual
->next
->expr
;
8715 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8716 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8722 gfc_init_se (&argse
, NULL
);
8723 gfc_conv_expr (&argse
, stat_expr
);
8724 gfc_add_block_to_block (&block
, &argse
.pre
);
8725 gfc_add_block_to_block (&post_block
, &argse
.post
);
8727 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8728 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8730 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8733 stat
= null_pointer_node
;
8735 /* Early exit for GFC_FCOARRAY_SINGLE. */
8736 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8738 if (stat
!= NULL_TREE
)
8739 gfc_add_modify (&block
, stat
,
8740 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8741 return gfc_finish_block (&block
);
8744 /* Handle the array. */
8745 gfc_init_se (&argse
, NULL
);
8746 if (code
->ext
.actual
->expr
->rank
== 0)
8748 symbol_attribute attr
;
8749 gfc_clear_attr (&attr
);
8750 gfc_init_se (&argse
, NULL
);
8751 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8752 gfc_add_block_to_block (&block
, &argse
.pre
);
8753 gfc_add_block_to_block (&post_block
, &argse
.post
);
8754 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8755 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8759 argse
.want_pointer
= 1;
8760 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8763 gfc_add_block_to_block (&block
, &argse
.pre
);
8764 gfc_add_block_to_block (&post_block
, &argse
.post
);
8766 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8767 strlen
= argse
.string_length
;
8769 strlen
= integer_zero_node
;
8774 gfc_init_se (&argse
, NULL
);
8775 gfc_conv_expr (&argse
, image_idx_expr
);
8776 gfc_add_block_to_block (&block
, &argse
.pre
);
8777 gfc_add_block_to_block (&post_block
, &argse
.post
);
8778 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8781 image_index
= integer_zero_node
;
8786 gfc_init_se (&argse
, NULL
);
8787 gfc_conv_expr (&argse
, errmsg_expr
);
8788 gfc_add_block_to_block (&block
, &argse
.pre
);
8789 gfc_add_block_to_block (&post_block
, &argse
.post
);
8790 errmsg
= argse
.expr
;
8791 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8795 errmsg
= null_pointer_node
;
8796 errmsg_len
= integer_zero_node
;
8799 /* Generate the function call. */
8800 switch (code
->resolved_isym
->id
)
8802 case GFC_ISYM_CO_BROADCAST
:
8803 fndecl
= gfor_fndecl_co_broadcast
;
8805 case GFC_ISYM_CO_MAX
:
8806 fndecl
= gfor_fndecl_co_max
;
8808 case GFC_ISYM_CO_MIN
:
8809 fndecl
= gfor_fndecl_co_min
;
8811 case GFC_ISYM_CO_REDUCE
:
8812 fndecl
= gfor_fndecl_co_reduce
;
8814 case GFC_ISYM_CO_SUM
:
8815 fndecl
= gfor_fndecl_co_sum
;
8821 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
8822 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
8823 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8824 image_index
, stat
, errmsg
, errmsg_len
);
8825 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
8826 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8827 stat
, errmsg
, strlen
, errmsg_len
);
8830 tree opr
, opr_flags
;
8832 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8834 if (gfc_is_proc_ptr_comp (opr_expr
))
8836 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
8837 opr_flag_int
= sym
->attr
.dimension
8838 || (sym
->ts
.type
== BT_CHARACTER
8839 && !sym
->attr
.is_bind_c
)
8840 ? GFC_CAF_BYREF
: 0;
8841 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8842 && !sym
->attr
.is_bind_c
8843 ? GFC_CAF_HIDDENLEN
: 0;
8844 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
8848 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
8849 ? GFC_CAF_BYREF
: 0;
8850 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8851 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
8852 ? GFC_CAF_HIDDENLEN
: 0;
8853 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
8854 ? GFC_CAF_ARG_VALUE
: 0;
8856 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
8857 gfc_conv_expr (&argse
, opr_expr
);
8859 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
8860 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
8863 gfc_add_expr_to_block (&block
, fndecl
);
8864 gfc_add_block_to_block (&block
, &post_block
);
8866 return gfc_finish_block (&block
);
8871 conv_intrinsic_atomic_op (gfc_code
*code
)
8874 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8875 stmtblock_t block
, post_block
;
8876 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8877 gfc_expr
*stat_expr
;
8878 built_in_function fn
;
8880 if (atom_expr
->expr_type
== EXPR_FUNCTION
8881 && atom_expr
->value
.function
.isym
8882 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8883 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8885 gfc_start_block (&block
);
8886 gfc_init_block (&post_block
);
8888 gfc_init_se (&argse
, NULL
);
8889 argse
.want_pointer
= 1;
8890 gfc_conv_expr (&argse
, atom_expr
);
8891 gfc_add_block_to_block (&block
, &argse
.pre
);
8892 gfc_add_block_to_block (&post_block
, &argse
.post
);
8895 gfc_init_se (&argse
, NULL
);
8896 if (flag_coarray
== GFC_FCOARRAY_LIB
8897 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8898 argse
.want_pointer
= 1;
8899 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8900 gfc_add_block_to_block (&block
, &argse
.pre
);
8901 gfc_add_block_to_block (&post_block
, &argse
.post
);
8904 switch (code
->resolved_isym
->id
)
8906 case GFC_ISYM_ATOMIC_ADD
:
8907 case GFC_ISYM_ATOMIC_AND
:
8908 case GFC_ISYM_ATOMIC_DEF
:
8909 case GFC_ISYM_ATOMIC_OR
:
8910 case GFC_ISYM_ATOMIC_XOR
:
8911 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8912 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8913 old
= null_pointer_node
;
8916 gfc_init_se (&argse
, NULL
);
8917 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8918 argse
.want_pointer
= 1;
8919 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8920 gfc_add_block_to_block (&block
, &argse
.pre
);
8921 gfc_add_block_to_block (&post_block
, &argse
.post
);
8923 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8927 if (stat_expr
!= NULL
)
8929 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8930 gfc_init_se (&argse
, NULL
);
8931 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8932 argse
.want_pointer
= 1;
8933 gfc_conv_expr_val (&argse
, stat_expr
);
8934 gfc_add_block_to_block (&block
, &argse
.pre
);
8935 gfc_add_block_to_block (&post_block
, &argse
.post
);
8938 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
8939 stat
= null_pointer_node
;
8941 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8943 tree image_index
, caf_decl
, offset
, token
;
8946 switch (code
->resolved_isym
->id
)
8948 case GFC_ISYM_ATOMIC_ADD
:
8949 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8950 op
= (int) GFC_CAF_ATOMIC_ADD
;
8952 case GFC_ISYM_ATOMIC_AND
:
8953 case GFC_ISYM_ATOMIC_FETCH_AND
:
8954 op
= (int) GFC_CAF_ATOMIC_AND
;
8956 case GFC_ISYM_ATOMIC_OR
:
8957 case GFC_ISYM_ATOMIC_FETCH_OR
:
8958 op
= (int) GFC_CAF_ATOMIC_OR
;
8960 case GFC_ISYM_ATOMIC_XOR
:
8961 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8962 op
= (int) GFC_CAF_ATOMIC_XOR
;
8964 case GFC_ISYM_ATOMIC_DEF
:
8965 op
= 0; /* Unused. */
8971 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8972 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8973 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8975 if (gfc_is_coindexed (atom_expr
))
8976 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
8978 image_index
= integer_zero_node
;
8980 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
8982 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
8983 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
8984 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8987 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8989 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
8990 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
8991 token
, offset
, image_index
, value
, stat
,
8992 build_int_cst (integer_type_node
,
8993 (int) atom_expr
->ts
.type
),
8994 build_int_cst (integer_type_node
,
8995 (int) atom_expr
->ts
.kind
));
8997 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
8998 build_int_cst (integer_type_node
, op
),
8999 token
, offset
, image_index
, value
, old
, stat
,
9000 build_int_cst (integer_type_node
,
9001 (int) atom_expr
->ts
.type
),
9002 build_int_cst (integer_type_node
,
9003 (int) atom_expr
->ts
.kind
));
9005 gfc_add_expr_to_block (&block
, tmp
);
9006 gfc_add_block_to_block (&block
, &post_block
);
9007 return gfc_finish_block (&block
);
9011 switch (code
->resolved_isym
->id
)
9013 case GFC_ISYM_ATOMIC_ADD
:
9014 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9015 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9017 case GFC_ISYM_ATOMIC_AND
:
9018 case GFC_ISYM_ATOMIC_FETCH_AND
:
9019 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9021 case GFC_ISYM_ATOMIC_DEF
:
9022 fn
= BUILT_IN_ATOMIC_STORE_N
;
9024 case GFC_ISYM_ATOMIC_OR
:
9025 case GFC_ISYM_ATOMIC_FETCH_OR
:
9026 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9028 case GFC_ISYM_ATOMIC_XOR
:
9029 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9030 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9036 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9037 fn
= (built_in_function
) ((int) fn
9038 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9040 tmp
= builtin_decl_explicit (fn
);
9041 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9042 tmp
= builtin_decl_explicit (fn
);
9044 switch (code
->resolved_isym
->id
)
9046 case GFC_ISYM_ATOMIC_ADD
:
9047 case GFC_ISYM_ATOMIC_AND
:
9048 case GFC_ISYM_ATOMIC_DEF
:
9049 case GFC_ISYM_ATOMIC_OR
:
9050 case GFC_ISYM_ATOMIC_XOR
:
9051 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9052 fold_convert (itype
, value
),
9053 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9054 gfc_add_expr_to_block (&block
, tmp
);
9057 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9058 fold_convert (itype
, value
),
9059 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9060 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9064 if (stat
!= NULL_TREE
)
9065 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9066 gfc_add_block_to_block (&block
, &post_block
);
9067 return gfc_finish_block (&block
);
9072 conv_intrinsic_atomic_ref (gfc_code
*code
)
9075 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9076 stmtblock_t block
, post_block
;
9077 built_in_function fn
;
9078 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9080 if (atom_expr
->expr_type
== EXPR_FUNCTION
9081 && atom_expr
->value
.function
.isym
9082 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9083 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9085 gfc_start_block (&block
);
9086 gfc_init_block (&post_block
);
9087 gfc_init_se (&argse
, NULL
);
9088 argse
.want_pointer
= 1;
9089 gfc_conv_expr (&argse
, atom_expr
);
9090 gfc_add_block_to_block (&block
, &argse
.pre
);
9091 gfc_add_block_to_block (&post_block
, &argse
.post
);
9094 gfc_init_se (&argse
, NULL
);
9095 if (flag_coarray
== GFC_FCOARRAY_LIB
9096 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9097 argse
.want_pointer
= 1;
9098 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9099 gfc_add_block_to_block (&block
, &argse
.pre
);
9100 gfc_add_block_to_block (&post_block
, &argse
.post
);
9104 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9106 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9108 gfc_init_se (&argse
, NULL
);
9109 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9110 argse
.want_pointer
= 1;
9111 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9112 gfc_add_block_to_block (&block
, &argse
.pre
);
9113 gfc_add_block_to_block (&post_block
, &argse
.post
);
9116 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9117 stat
= null_pointer_node
;
9119 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9121 tree image_index
, caf_decl
, offset
, token
;
9122 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9124 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9125 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9126 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9128 if (gfc_is_coindexed (atom_expr
))
9129 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9131 image_index
= integer_zero_node
;
9133 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9135 /* Different type, need type conversion. */
9136 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9138 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9140 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9143 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9144 token
, offset
, image_index
, value
, stat
,
9145 build_int_cst (integer_type_node
,
9146 (int) atom_expr
->ts
.type
),
9147 build_int_cst (integer_type_node
,
9148 (int) atom_expr
->ts
.kind
));
9149 gfc_add_expr_to_block (&block
, tmp
);
9150 if (vardecl
!= NULL_TREE
)
9151 gfc_add_modify (&block
, orig_value
,
9152 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9153 gfc_add_block_to_block (&block
, &post_block
);
9154 return gfc_finish_block (&block
);
9157 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9158 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9159 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9161 tmp
= builtin_decl_explicit (fn
);
9162 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9163 build_int_cst (integer_type_node
,
9165 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9167 if (stat
!= NULL_TREE
)
9168 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9169 gfc_add_block_to_block (&block
, &post_block
);
9170 return gfc_finish_block (&block
);
9175 conv_intrinsic_atomic_cas (gfc_code
*code
)
9178 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9179 stmtblock_t block
, post_block
;
9180 built_in_function fn
;
9181 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9183 if (atom_expr
->expr_type
== EXPR_FUNCTION
9184 && atom_expr
->value
.function
.isym
9185 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9186 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9188 gfc_init_block (&block
);
9189 gfc_init_block (&post_block
);
9190 gfc_init_se (&argse
, NULL
);
9191 argse
.want_pointer
= 1;
9192 gfc_conv_expr (&argse
, atom_expr
);
9195 gfc_init_se (&argse
, NULL
);
9196 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9197 argse
.want_pointer
= 1;
9198 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9199 gfc_add_block_to_block (&block
, &argse
.pre
);
9200 gfc_add_block_to_block (&post_block
, &argse
.post
);
9203 gfc_init_se (&argse
, NULL
);
9204 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9205 argse
.want_pointer
= 1;
9206 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9207 gfc_add_block_to_block (&block
, &argse
.pre
);
9208 gfc_add_block_to_block (&post_block
, &argse
.post
);
9211 gfc_init_se (&argse
, NULL
);
9212 if (flag_coarray
== GFC_FCOARRAY_LIB
9213 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9214 == atom_expr
->ts
.kind
)
9215 argse
.want_pointer
= 1;
9216 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9217 gfc_add_block_to_block (&block
, &argse
.pre
);
9218 gfc_add_block_to_block (&post_block
, &argse
.post
);
9219 new_val
= argse
.expr
;
9222 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9224 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9226 gfc_init_se (&argse
, NULL
);
9227 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9228 argse
.want_pointer
= 1;
9229 gfc_conv_expr_val (&argse
,
9230 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9231 gfc_add_block_to_block (&block
, &argse
.pre
);
9232 gfc_add_block_to_block (&post_block
, &argse
.post
);
9235 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9236 stat
= null_pointer_node
;
9238 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9240 tree image_index
, caf_decl
, offset
, token
;
9242 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9243 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9244 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9246 if (gfc_is_coindexed (atom_expr
))
9247 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9249 image_index
= integer_zero_node
;
9251 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9253 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9254 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9255 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9258 /* Convert a constant to a pointer. */
9259 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
9261 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
9262 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
9263 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9266 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9268 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
9269 token
, offset
, image_index
, old
, comp
, new_val
,
9270 stat
, build_int_cst (integer_type_node
,
9271 (int) atom_expr
->ts
.type
),
9272 build_int_cst (integer_type_node
,
9273 (int) atom_expr
->ts
.kind
));
9274 gfc_add_expr_to_block (&block
, tmp
);
9275 gfc_add_block_to_block (&block
, &post_block
);
9276 return gfc_finish_block (&block
);
9279 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9280 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9281 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9283 tmp
= builtin_decl_explicit (fn
);
9285 gfc_add_modify (&block
, old
, comp
);
9286 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
9287 gfc_build_addr_expr (NULL
, old
),
9288 fold_convert (TREE_TYPE (old
), new_val
),
9290 build_int_cst (NULL
, MEMMODEL_RELAXED
),
9291 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9292 gfc_add_expr_to_block (&block
, tmp
);
9294 if (stat
!= NULL_TREE
)
9295 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9296 gfc_add_block_to_block (&block
, &post_block
);
9297 return gfc_finish_block (&block
);
9302 conv_intrinsic_move_alloc (gfc_code
*code
)
9305 gfc_expr
*from_expr
, *to_expr
;
9306 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
9307 gfc_se from_se
, to_se
;
9311 gfc_start_block (&block
);
9313 from_expr
= code
->ext
.actual
->expr
;
9314 to_expr
= code
->ext
.actual
->next
->expr
;
9316 gfc_init_se (&from_se
, NULL
);
9317 gfc_init_se (&to_se
, NULL
);
9319 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
9320 || to_expr
->ts
.type
== BT_CLASS
);
9321 coarray
= gfc_get_corank (from_expr
) != 0;
9323 if (from_expr
->rank
== 0 && !coarray
)
9325 if (from_expr
->ts
.type
!= BT_CLASS
)
9326 from_expr2
= from_expr
;
9329 from_expr2
= gfc_copy_expr (from_expr
);
9330 gfc_add_data_component (from_expr2
);
9333 if (to_expr
->ts
.type
!= BT_CLASS
)
9337 to_expr2
= gfc_copy_expr (to_expr
);
9338 gfc_add_data_component (to_expr2
);
9341 from_se
.want_pointer
= 1;
9342 to_se
.want_pointer
= 1;
9343 gfc_conv_expr (&from_se
, from_expr2
);
9344 gfc_conv_expr (&to_se
, to_expr2
);
9345 gfc_add_block_to_block (&block
, &from_se
.pre
);
9346 gfc_add_block_to_block (&block
, &to_se
.pre
);
9348 /* Deallocate "to". */
9349 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
9350 to_expr
, to_expr
->ts
);
9351 gfc_add_expr_to_block (&block
, tmp
);
9353 /* Assign (_data) pointers. */
9354 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9355 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
9357 /* Set "from" to NULL. */
9358 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9359 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
9361 gfc_add_block_to_block (&block
, &from_se
.post
);
9362 gfc_add_block_to_block (&block
, &to_se
.post
);
9365 if (to_expr
->ts
.type
== BT_CLASS
)
9369 gfc_free_expr (to_expr2
);
9370 gfc_init_se (&to_se
, NULL
);
9371 to_se
.want_pointer
= 1;
9372 gfc_add_vptr_component (to_expr
);
9373 gfc_conv_expr (&to_se
, to_expr
);
9375 if (from_expr
->ts
.type
== BT_CLASS
)
9377 if (UNLIMITED_POLY (from_expr
))
9381 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9385 gfc_free_expr (from_expr2
);
9386 gfc_init_se (&from_se
, NULL
);
9387 from_se
.want_pointer
= 1;
9388 gfc_add_vptr_component (from_expr
);
9389 gfc_conv_expr (&from_se
, from_expr
);
9390 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9391 fold_convert (TREE_TYPE (to_se
.expr
),
9394 /* Reset _vptr component to declared type. */
9396 /* Unlimited polymorphic. */
9397 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9398 fold_convert (TREE_TYPE (from_se
.expr
),
9399 null_pointer_node
));
9402 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9403 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9404 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9409 vtab
= gfc_find_vtab (&from_expr
->ts
);
9411 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9412 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9413 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9417 return gfc_finish_block (&block
);
9420 /* Update _vptr component. */
9421 if (to_expr
->ts
.type
== BT_CLASS
)
9425 to_se
.want_pointer
= 1;
9426 to_expr2
= gfc_copy_expr (to_expr
);
9427 gfc_add_vptr_component (to_expr2
);
9428 gfc_conv_expr (&to_se
, to_expr2
);
9430 if (from_expr
->ts
.type
== BT_CLASS
)
9432 if (UNLIMITED_POLY (from_expr
))
9436 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9440 from_se
.want_pointer
= 1;
9441 from_expr2
= gfc_copy_expr (from_expr
);
9442 gfc_add_vptr_component (from_expr2
);
9443 gfc_conv_expr (&from_se
, from_expr2
);
9444 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9445 fold_convert (TREE_TYPE (to_se
.expr
),
9448 /* Reset _vptr component to declared type. */
9450 /* Unlimited polymorphic. */
9451 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9452 fold_convert (TREE_TYPE (from_se
.expr
),
9453 null_pointer_node
));
9456 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9457 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9458 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9463 vtab
= gfc_find_vtab (&from_expr
->ts
);
9465 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9466 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9467 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9470 gfc_free_expr (to_expr2
);
9471 gfc_init_se (&to_se
, NULL
);
9473 if (from_expr
->ts
.type
== BT_CLASS
)
9475 gfc_free_expr (from_expr2
);
9476 gfc_init_se (&from_se
, NULL
);
9481 /* Deallocate "to". */
9482 if (from_expr
->rank
== 0)
9484 to_se
.want_coarray
= 1;
9485 from_se
.want_coarray
= 1;
9487 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9488 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9490 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9491 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9492 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9496 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9497 NULL_TREE
, NULL_TREE
, true, to_expr
,
9499 gfc_add_expr_to_block (&block
, tmp
);
9501 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9502 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9503 boolean_type_node
, tmp
,
9504 fold_convert (TREE_TYPE (tmp
),
9505 null_pointer_node
));
9506 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9507 3, null_pointer_node
, null_pointer_node
,
9508 build_int_cst (integer_type_node
, 0));
9510 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9511 tmp
, build_empty_stmt (input_location
));
9512 gfc_add_expr_to_block (&block
, tmp
);
9516 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9517 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9518 NULL_TREE
, true, to_expr
, false);
9519 gfc_add_expr_to_block (&block
, tmp
);
9522 /* Move the pointer and update the array descriptor data. */
9523 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9525 /* Set "from" to NULL. */
9526 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9527 gfc_add_modify_loc (input_location
, &block
, tmp
,
9528 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9530 return gfc_finish_block (&block
);
9535 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9539 gcc_assert (code
->resolved_isym
);
9541 switch (code
->resolved_isym
->id
)
9543 case GFC_ISYM_MOVE_ALLOC
:
9544 res
= conv_intrinsic_move_alloc (code
);
9547 case GFC_ISYM_ATOMIC_CAS
:
9548 res
= conv_intrinsic_atomic_cas (code
);
9551 case GFC_ISYM_ATOMIC_ADD
:
9552 case GFC_ISYM_ATOMIC_AND
:
9553 case GFC_ISYM_ATOMIC_DEF
:
9554 case GFC_ISYM_ATOMIC_OR
:
9555 case GFC_ISYM_ATOMIC_XOR
:
9556 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9557 case GFC_ISYM_ATOMIC_FETCH_AND
:
9558 case GFC_ISYM_ATOMIC_FETCH_OR
:
9559 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9560 res
= conv_intrinsic_atomic_op (code
);
9563 case GFC_ISYM_ATOMIC_REF
:
9564 res
= conv_intrinsic_atomic_ref (code
);
9567 case GFC_ISYM_C_F_POINTER
:
9568 case GFC_ISYM_C_F_PROCPOINTER
:
9569 res
= conv_isocbinding_subroutine (code
);
9572 case GFC_ISYM_CAF_SEND
:
9573 res
= conv_caf_send (code
);
9576 case GFC_ISYM_CO_BROADCAST
:
9577 case GFC_ISYM_CO_MIN
:
9578 case GFC_ISYM_CO_MAX
:
9579 case GFC_ISYM_CO_REDUCE
:
9580 case GFC_ISYM_CO_SUM
:
9581 res
= conv_co_collective (code
);
9585 res
= conv_intrinsic_free (code
);
9588 case GFC_ISYM_SYSTEM_CLOCK
:
9589 res
= conv_intrinsic_system_clock (code
);
9600 #include "gt-fortran-trans-intrinsic.h"