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
, current_function_decl
);
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
, current_function_decl
);
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
, current_function_decl
);
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
, current_function_decl
);
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
, current_function_decl
);
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
, current_function_decl
);
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
, current_function_decl
);
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 /* For deferred length arrays, conv_expr_descriptor returns an
5941 indirect_ref to the component. */
5943 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
5944 && GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0))))
5945 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
5946 else if (arg
->rank
> 0)
5947 /* The scalarizer added an additional temp. To get the class' vptr
5948 one has to look at the original backend_decl. */
5949 byte_size
= gfc_class_vtab_size_get (
5950 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
5952 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
5956 if (arg
->ts
.type
== BT_CHARACTER
)
5957 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5961 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5964 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5965 byte_size
= fold_convert (gfc_array_index_type
,
5966 size_in_bytes (byte_size
));
5971 se
->expr
= byte_size
;
5974 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5975 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
5977 if (arg
->rank
== -1)
5979 tree cond
, loop_var
, exit_label
;
5982 tmp
= fold_convert (gfc_array_index_type
,
5983 gfc_conv_descriptor_rank (argse
.expr
));
5984 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
5985 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
5986 exit_label
= gfc_build_label_decl (NULL_TREE
);
5993 source_bytes = source_bytes * array.dim[i].extent;
5997 gfc_start_block (&body
);
5998 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6000 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6001 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6002 cond
, tmp
, build_empty_stmt (input_location
));
6003 gfc_add_expr_to_block (&body
, tmp
);
6005 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6006 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6007 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6008 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6009 gfc_array_index_type
, tmp
, source_bytes
);
6010 gfc_add_modify (&body
, source_bytes
, tmp
);
6012 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6013 gfc_array_index_type
, loop_var
,
6014 gfc_index_one_node
);
6015 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6017 tmp
= gfc_finish_block (&body
);
6019 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6021 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6023 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6024 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6028 /* Obtain the size of the array in bytes. */
6029 for (n
= 0; n
< arg
->rank
; n
++)
6032 idx
= gfc_rank_cst
[n
];
6033 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6034 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6035 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6036 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6037 gfc_array_index_type
, tmp
, source_bytes
);
6038 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6041 se
->expr
= source_bytes
;
6044 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6049 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6053 tree type
, result_type
, tmp
;
6055 arg
= expr
->value
.function
.actual
->expr
;
6057 gfc_init_se (&argse
, NULL
);
6058 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6062 if (arg
->ts
.type
== BT_CLASS
)
6064 gfc_add_vptr_component (arg
);
6065 gfc_add_size_component (arg
);
6066 gfc_conv_expr (&argse
, arg
);
6067 tmp
= fold_convert (result_type
, argse
.expr
);
6071 gfc_conv_expr_reference (&argse
, arg
);
6072 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6077 argse
.want_pointer
= 0;
6078 gfc_conv_expr_descriptor (&argse
, arg
);
6079 if (arg
->ts
.type
== BT_CLASS
)
6082 tmp
= gfc_class_vtab_size_get (
6083 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6085 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6086 tmp
= fold_convert (result_type
, tmp
);
6089 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6092 /* Obtain the argument's word length. */
6093 if (arg
->ts
.type
== BT_CHARACTER
)
6094 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6096 tmp
= size_in_bytes (type
);
6097 tmp
= fold_convert (result_type
, tmp
);
6100 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6101 build_int_cst (result_type
, BITS_PER_UNIT
));
6102 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6106 /* Intrinsic string comparison functions. */
6109 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6113 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6116 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6117 expr
->value
.function
.actual
->expr
->ts
.kind
,
6119 se
->expr
= fold_build2_loc (input_location
, op
,
6120 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6121 build_int_cst (TREE_TYPE (se
->expr
), 0));
6124 /* Generate a call to the adjustl/adjustr library function. */
6126 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6134 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6137 type
= TREE_TYPE (args
[2]);
6138 var
= gfc_conv_string_tmp (se
, type
, len
);
6141 tmp
= build_call_expr_loc (input_location
,
6142 fndecl
, 3, args
[0], args
[1], args
[2]);
6143 gfc_add_expr_to_block (&se
->pre
, tmp
);
6145 se
->string_length
= len
;
6149 /* Generate code for the TRANSFER intrinsic:
6151 DEST = TRANSFER (SOURCE, MOLD)
6153 typeof<DEST> = typeof<MOLD>
6158 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6160 typeof<DEST> = typeof<MOLD>
6162 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6163 sizeof (DEST(0) * SIZE). */
6165 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6181 gfc_actual_arglist
*arg
;
6183 gfc_array_info
*info
;
6187 gfc_expr
*source_expr
, *mold_expr
;
6191 info
= &se
->ss
->info
->data
.array
;
6193 /* Convert SOURCE. The output from this stage is:-
6194 source_bytes = length of the source in bytes
6195 source = pointer to the source data. */
6196 arg
= expr
->value
.function
.actual
;
6197 source_expr
= arg
->expr
;
6199 /* Ensure double transfer through LOGICAL preserves all
6201 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6202 && arg
->expr
->value
.function
.esym
== NULL
6203 && arg
->expr
->value
.function
.isym
!= NULL
6204 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6205 && arg
->expr
->ts
.type
== BT_LOGICAL
6206 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6207 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6209 gfc_init_se (&argse
, NULL
);
6211 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6213 /* Obtain the pointer to source and the length of source in bytes. */
6214 if (arg
->expr
->rank
== 0)
6216 gfc_conv_expr_reference (&argse
, arg
->expr
);
6217 if (arg
->expr
->ts
.type
== BT_CLASS
)
6218 source
= gfc_class_data_get (argse
.expr
);
6220 source
= argse
.expr
;
6222 /* Obtain the source word length. */
6223 switch (arg
->expr
->ts
.type
)
6226 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6227 argse
.string_length
);
6230 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6233 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6235 tmp
= fold_convert (gfc_array_index_type
,
6236 size_in_bytes (source_type
));
6242 argse
.want_pointer
= 0;
6243 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6244 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6245 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6247 /* Repack the source if not simply contiguous. */
6248 if (!gfc_is_simply_contiguous (arg
->expr
, false))
6250 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6252 if (warn_array_temporaries
)
6253 gfc_warning (OPT_Warray_temporaries
,
6254 "Creating array temporary at %L", &expr
->where
);
6256 source
= build_call_expr_loc (input_location
,
6257 gfor_fndecl_in_pack
, 1, tmp
);
6258 source
= gfc_evaluate_now (source
, &argse
.pre
);
6260 /* Free the temporary. */
6261 gfc_start_block (&block
);
6262 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
6263 gfc_add_expr_to_block (&block
, tmp
);
6264 stmt
= gfc_finish_block (&block
);
6266 /* Clean up if it was repacked. */
6267 gfc_init_block (&block
);
6268 tmp
= gfc_conv_array_data (argse
.expr
);
6269 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6271 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6272 build_empty_stmt (input_location
));
6273 gfc_add_expr_to_block (&block
, tmp
);
6274 gfc_add_block_to_block (&block
, &se
->post
);
6275 gfc_init_block (&se
->post
);
6276 gfc_add_block_to_block (&se
->post
, &block
);
6279 /* Obtain the source word length. */
6280 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6281 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6282 argse
.string_length
);
6284 tmp
= fold_convert (gfc_array_index_type
,
6285 size_in_bytes (source_type
));
6287 /* Obtain the size of the array in bytes. */
6288 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6289 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6292 idx
= gfc_rank_cst
[n
];
6293 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6294 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6295 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6296 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6297 gfc_array_index_type
, upper
, lower
);
6298 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6299 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6300 gfc_array_index_type
, extent
,
6301 gfc_index_one_node
);
6302 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6303 gfc_array_index_type
, tmp
, source_bytes
);
6307 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6308 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6309 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6311 /* Now convert MOLD. The outputs are:
6312 mold_type = the TREE type of MOLD
6313 dest_word_len = destination word length in bytes. */
6315 mold_expr
= arg
->expr
;
6317 gfc_init_se (&argse
, NULL
);
6319 scalar_mold
= arg
->expr
->rank
== 0;
6321 if (arg
->expr
->rank
== 0)
6323 gfc_conv_expr_reference (&argse
, arg
->expr
);
6324 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6329 gfc_init_se (&argse
, NULL
);
6330 argse
.want_pointer
= 0;
6331 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6332 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6335 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6336 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6338 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6340 /* If this TRANSFER is nested in another TRANSFER, use a type
6341 that preserves all bits. */
6342 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6343 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6346 /* Obtain the destination word length. */
6347 switch (arg
->expr
->ts
.type
)
6350 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6351 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6354 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6357 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6360 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6361 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6363 /* Finally convert SIZE, if it is present. */
6365 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6369 gfc_init_se (&argse
, NULL
);
6370 gfc_conv_expr_reference (&argse
, arg
->expr
);
6371 tmp
= convert (gfc_array_index_type
,
6372 build_fold_indirect_ref_loc (input_location
,
6374 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6375 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6380 /* Separate array and scalar results. */
6381 if (scalar_mold
&& tmp
== NULL_TREE
)
6382 goto scalar_transfer
;
6384 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6385 if (tmp
!= NULL_TREE
)
6386 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6387 tmp
, dest_word_len
);
6391 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6392 gfc_add_modify (&se
->pre
, size_words
,
6393 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6394 gfc_array_index_type
,
6395 size_bytes
, dest_word_len
));
6397 /* Evaluate the bounds of the result. If the loop range exists, we have
6398 to check if it is too large. If so, we modify loop->to be consistent
6399 with min(size, size(source)). Otherwise, size is made consistent with
6400 the loop range, so that the right number of bytes is transferred.*/
6401 n
= se
->loop
->order
[0];
6402 if (se
->loop
->to
[n
] != NULL_TREE
)
6404 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6405 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6406 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6407 tmp
, gfc_index_one_node
);
6408 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6410 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6411 gfc_add_modify (&se
->pre
, size_bytes
,
6412 fold_build2_loc (input_location
, MULT_EXPR
,
6413 gfc_array_index_type
,
6414 size_words
, dest_word_len
));
6415 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6416 size_words
, se
->loop
->from
[n
]);
6417 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6418 upper
, gfc_index_one_node
);
6422 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6423 size_words
, gfc_index_one_node
);
6424 se
->loop
->from
[n
] = gfc_index_zero_node
;
6427 se
->loop
->to
[n
] = upper
;
6429 /* Build a destination descriptor, using the pointer, source, as the
6431 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6432 NULL_TREE
, false, true, false, &expr
->where
);
6434 /* Cast the pointer to the result. */
6435 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6436 tmp
= fold_convert (pvoid_type_node
, tmp
);
6438 /* Use memcpy to do the transfer. */
6440 = build_call_expr_loc (input_location
,
6441 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6442 fold_convert (pvoid_type_node
, source
),
6443 fold_convert (size_type_node
,
6444 fold_build2_loc (input_location
,
6446 gfc_array_index_type
,
6449 gfc_add_expr_to_block (&se
->pre
, tmp
);
6451 se
->expr
= info
->descriptor
;
6452 if (expr
->ts
.type
== BT_CHARACTER
)
6453 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6457 /* Deal with scalar results. */
6459 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6460 dest_word_len
, source_bytes
);
6461 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6462 extent
, gfc_index_zero_node
);
6464 if (expr
->ts
.type
== BT_CHARACTER
)
6466 tree direct
, indirect
, free
;
6468 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6469 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6472 /* If source is longer than the destination, use a pointer to
6473 the source directly. */
6474 gfc_init_block (&block
);
6475 gfc_add_modify (&block
, tmpdecl
, ptr
);
6476 direct
= gfc_finish_block (&block
);
6478 /* Otherwise, allocate a string with the length of the destination
6479 and copy the source into it. */
6480 gfc_init_block (&block
);
6481 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6482 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6483 gfc_add_modify (&block
, tmpdecl
,
6484 fold_convert (TREE_TYPE (ptr
), tmp
));
6485 tmp
= build_call_expr_loc (input_location
,
6486 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6487 fold_convert (pvoid_type_node
, tmpdecl
),
6488 fold_convert (pvoid_type_node
, ptr
),
6489 fold_convert (size_type_node
, extent
));
6490 gfc_add_expr_to_block (&block
, tmp
);
6491 indirect
= gfc_finish_block (&block
);
6493 /* Wrap it up with the condition. */
6494 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6495 dest_word_len
, source_bytes
);
6496 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6497 gfc_add_expr_to_block (&se
->pre
, tmp
);
6499 /* Free the temporary string, if necessary. */
6500 free
= gfc_call_free (tmpdecl
);
6501 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6502 dest_word_len
, source_bytes
);
6503 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6504 gfc_add_expr_to_block (&se
->post
, tmp
);
6507 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6511 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6513 ptr
= convert (build_pointer_type (mold_type
), source
);
6515 /* For CLASS results, allocate the needed memory first. */
6516 if (mold_expr
->ts
.type
== BT_CLASS
)
6519 cdata
= gfc_class_data_get (tmpdecl
);
6520 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6521 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6524 /* Use memcpy to do the transfer. */
6525 if (mold_expr
->ts
.type
== BT_CLASS
)
6526 tmp
= gfc_class_data_get (tmpdecl
);
6528 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6530 tmp
= build_call_expr_loc (input_location
,
6531 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6532 fold_convert (pvoid_type_node
, tmp
),
6533 fold_convert (pvoid_type_node
, ptr
),
6534 fold_convert (size_type_node
, extent
));
6535 gfc_add_expr_to_block (&se
->pre
, tmp
);
6537 /* For CLASS results, set the _vptr. */
6538 if (mold_expr
->ts
.type
== BT_CLASS
)
6542 vptr
= gfc_class_vptr_get (tmpdecl
);
6543 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6545 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6546 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6554 /* Generate code for the ALLOCATED intrinsic.
6555 Generate inline code that directly check the address of the argument. */
6558 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6560 gfc_actual_arglist
*arg1
;
6564 gfc_init_se (&arg1se
, NULL
);
6565 arg1
= expr
->value
.function
.actual
;
6567 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6569 /* Make sure that class array expressions have both a _data
6570 component reference and an array reference.... */
6571 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6572 gfc_add_class_array_ref (arg1
->expr
);
6573 /* .... whilst scalars only need the _data component. */
6575 gfc_add_data_component (arg1
->expr
);
6578 if (arg1
->expr
->rank
== 0)
6580 /* Allocatable scalar. */
6581 arg1se
.want_pointer
= 1;
6582 gfc_conv_expr (&arg1se
, arg1
->expr
);
6587 /* Allocatable array. */
6588 arg1se
.descriptor_only
= 1;
6589 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6590 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6593 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6594 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6595 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6599 /* Generate code for the ASSOCIATED intrinsic.
6600 If both POINTER and TARGET are arrays, generate a call to library function
6601 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6602 In other cases, generate inline code that directly compare the address of
6603 POINTER with the address of TARGET. */
6606 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6608 gfc_actual_arglist
*arg1
;
6609 gfc_actual_arglist
*arg2
;
6614 tree nonzero_charlen
;
6615 tree nonzero_arraylen
;
6619 gfc_init_se (&arg1se
, NULL
);
6620 gfc_init_se (&arg2se
, NULL
);
6621 arg1
= expr
->value
.function
.actual
;
6624 /* Check whether the expression is a scalar or not; we cannot use
6625 arg1->expr->rank as it can be nonzero for proc pointers. */
6626 ss
= gfc_walk_expr (arg1
->expr
);
6627 scalar
= ss
== gfc_ss_terminator
;
6629 gfc_free_ss_chain (ss
);
6633 /* No optional target. */
6636 /* A pointer to a scalar. */
6637 arg1se
.want_pointer
= 1;
6638 gfc_conv_expr (&arg1se
, arg1
->expr
);
6639 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6640 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6641 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6643 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6645 tmp2
= gfc_class_data_get (arg1se
.expr
);
6646 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6647 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6654 /* A pointer to an array. */
6655 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6656 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6658 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6659 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6660 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6661 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6666 /* An optional target. */
6667 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6668 gfc_add_data_component (arg2
->expr
);
6670 nonzero_charlen
= NULL_TREE
;
6671 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6672 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6674 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6678 /* A pointer to a scalar. */
6679 arg1se
.want_pointer
= 1;
6680 gfc_conv_expr (&arg1se
, arg1
->expr
);
6681 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6682 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6683 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6685 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6686 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6688 arg2se
.want_pointer
= 1;
6689 gfc_conv_expr (&arg2se
, arg2
->expr
);
6690 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6691 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6692 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6694 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6695 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6696 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6697 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6698 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6699 arg1se
.expr
, arg2se
.expr
);
6700 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6701 arg1se
.expr
, null_pointer_node
);
6702 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6703 boolean_type_node
, tmp
, tmp2
);
6707 /* An array pointer of zero length is not associated if target is
6709 arg1se
.descriptor_only
= 1;
6710 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6711 if (arg1
->expr
->rank
== -1)
6713 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6714 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6715 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6718 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6719 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6720 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6721 boolean_type_node
, tmp
,
6722 build_int_cst (TREE_TYPE (tmp
), 0));
6724 /* A pointer to an array, call library function _gfor_associated. */
6725 arg1se
.want_pointer
= 1;
6726 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6728 arg2se
.want_pointer
= 1;
6729 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6730 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6731 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6732 se
->expr
= build_call_expr_loc (input_location
,
6733 gfor_fndecl_associated
, 2,
6734 arg1se
.expr
, arg2se
.expr
);
6735 se
->expr
= convert (boolean_type_node
, se
->expr
);
6736 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6737 boolean_type_node
, se
->expr
,
6741 /* If target is present zero character length pointers cannot
6743 if (nonzero_charlen
!= NULL_TREE
)
6744 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6746 se
->expr
, nonzero_charlen
);
6749 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6753 /* Generate code for the SAME_TYPE_AS intrinsic.
6754 Generate inline code that directly checks the vindices. */
6757 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6762 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6764 gfc_init_se (&se1
, NULL
);
6765 gfc_init_se (&se2
, NULL
);
6767 a
= expr
->value
.function
.actual
->expr
;
6768 b
= expr
->value
.function
.actual
->next
->expr
;
6770 if (UNLIMITED_POLY (a
))
6772 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6773 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6774 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6777 if (UNLIMITED_POLY (b
))
6779 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6780 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6781 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6784 if (a
->ts
.type
== BT_CLASS
)
6786 gfc_add_vptr_component (a
);
6787 gfc_add_hash_component (a
);
6789 else if (a
->ts
.type
== BT_DERIVED
)
6790 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6791 a
->ts
.u
.derived
->hash_value
);
6793 if (b
->ts
.type
== BT_CLASS
)
6795 gfc_add_vptr_component (b
);
6796 gfc_add_hash_component (b
);
6798 else if (b
->ts
.type
== BT_DERIVED
)
6799 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6800 b
->ts
.u
.derived
->hash_value
);
6802 gfc_conv_expr (&se1
, a
);
6803 gfc_conv_expr (&se2
, b
);
6805 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6806 boolean_type_node
, se1
.expr
,
6807 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6810 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6811 boolean_type_node
, conda
, tmp
);
6814 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6815 boolean_type_node
, condb
, tmp
);
6817 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6821 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6824 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6828 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6829 se
->expr
= build_call_expr_loc (input_location
,
6830 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6831 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6835 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6838 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6842 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6844 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6845 type
= gfc_get_int_type (4);
6846 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6848 /* Convert it to the required type. */
6849 type
= gfc_typenode_for_spec (&expr
->ts
);
6850 se
->expr
= build_call_expr_loc (input_location
,
6851 gfor_fndecl_si_kind
, 1, arg
);
6852 se
->expr
= fold_convert (type
, se
->expr
);
6856 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6859 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6861 gfc_actual_arglist
*actual
;
6864 vec
<tree
, va_gc
> *args
= NULL
;
6866 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6868 gfc_init_se (&argse
, se
);
6870 /* Pass a NULL pointer for an absent arg. */
6871 if (actual
->expr
== NULL
)
6872 argse
.expr
= null_pointer_node
;
6878 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6880 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6881 ts
.type
= BT_INTEGER
;
6882 ts
.kind
= gfc_c_int_kind
;
6883 gfc_convert_type (actual
->expr
, &ts
, 2);
6885 gfc_conv_expr_reference (&argse
, actual
->expr
);
6888 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6889 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6890 vec_safe_push (args
, argse
.expr
);
6893 /* Convert it to the required type. */
6894 type
= gfc_typenode_for_spec (&expr
->ts
);
6895 se
->expr
= build_call_expr_loc_vec (input_location
,
6896 gfor_fndecl_sr_kind
, args
);
6897 se
->expr
= fold_convert (type
, se
->expr
);
6901 /* Generate code for TRIM (A) intrinsic function. */
6904 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6914 unsigned int num_args
;
6916 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6917 args
= XALLOCAVEC (tree
, num_args
);
6919 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6920 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6921 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6923 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6924 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6927 if (expr
->ts
.kind
== 1)
6928 function
= gfor_fndecl_string_trim
;
6929 else if (expr
->ts
.kind
== 4)
6930 function
= gfor_fndecl_string_trim_char4
;
6934 fndecl
= build_addr (function
, current_function_decl
);
6935 tmp
= build_call_array_loc (input_location
,
6936 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6938 gfc_add_expr_to_block (&se
->pre
, tmp
);
6940 /* Free the temporary afterwards, if necessary. */
6941 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6942 len
, build_int_cst (TREE_TYPE (len
), 0));
6943 tmp
= gfc_call_free (var
);
6944 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6945 gfc_add_expr_to_block (&se
->post
, tmp
);
6948 se
->string_length
= len
;
6952 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6955 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6957 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6958 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6960 stmtblock_t block
, body
;
6963 /* We store in charsize the size of a character. */
6964 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6965 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6967 /* Get the arguments. */
6968 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6969 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6971 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6972 ncopies_type
= TREE_TYPE (ncopies
);
6974 /* Check that NCOPIES is not negative. */
6975 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6976 build_int_cst (ncopies_type
, 0));
6977 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6978 "Argument NCOPIES of REPEAT intrinsic is negative "
6979 "(its value is %ld)",
6980 fold_convert (long_integer_type_node
, ncopies
));
6982 /* If the source length is zero, any non negative value of NCOPIES
6983 is valid, and nothing happens. */
6984 n
= gfc_create_var (ncopies_type
, "ncopies");
6985 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6986 build_int_cst (size_type_node
, 0));
6987 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6988 build_int_cst (ncopies_type
, 0), ncopies
);
6989 gfc_add_modify (&se
->pre
, n
, tmp
);
6992 /* Check that ncopies is not too large: ncopies should be less than
6993 (or equal to) MAX / slen, where MAX is the maximal integer of
6994 the gfc_charlen_type_node type. If slen == 0, we need a special
6995 case to avoid the division by zero. */
6996 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6997 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6998 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6999 fold_convert (size_type_node
, max
), slen
);
7000 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7001 ? size_type_node
: ncopies_type
;
7002 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7003 fold_convert (largest
, ncopies
),
7004 fold_convert (largest
, max
));
7005 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7006 build_int_cst (size_type_node
, 0));
7007 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7008 boolean_false_node
, cond
);
7009 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7010 "Argument NCOPIES of REPEAT intrinsic is too large");
7012 /* Compute the destination length. */
7013 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7014 fold_convert (gfc_charlen_type_node
, slen
),
7015 fold_convert (gfc_charlen_type_node
, ncopies
));
7016 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7017 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7019 /* Generate the code to do the repeat operation:
7020 for (i = 0; i < ncopies; i++)
7021 memmove (dest + (i * slen * size), src, slen*size); */
7022 gfc_start_block (&block
);
7023 count
= gfc_create_var (ncopies_type
, "count");
7024 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7025 exit_label
= gfc_build_label_decl (NULL_TREE
);
7027 /* Start the loop body. */
7028 gfc_start_block (&body
);
7030 /* Exit the loop if count >= ncopies. */
7031 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7033 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7034 TREE_USED (exit_label
) = 1;
7035 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7036 build_empty_stmt (input_location
));
7037 gfc_add_expr_to_block (&body
, tmp
);
7039 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7040 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7041 fold_convert (gfc_charlen_type_node
, slen
),
7042 fold_convert (gfc_charlen_type_node
, count
));
7043 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7044 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7045 tmp
= fold_build_pointer_plus_loc (input_location
,
7046 fold_convert (pvoid_type_node
, dest
), tmp
);
7047 tmp
= build_call_expr_loc (input_location
,
7048 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7050 fold_build2_loc (input_location
, MULT_EXPR
,
7051 size_type_node
, slen
,
7052 fold_convert (size_type_node
,
7054 gfc_add_expr_to_block (&body
, tmp
);
7056 /* Increment count. */
7057 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7058 count
, build_int_cst (TREE_TYPE (count
), 1));
7059 gfc_add_modify (&body
, count
, tmp
);
7061 /* Build the loop. */
7062 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7063 gfc_add_expr_to_block (&block
, tmp
);
7065 /* Add the exit label. */
7066 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7067 gfc_add_expr_to_block (&block
, tmp
);
7069 /* Finish the block. */
7070 tmp
= gfc_finish_block (&block
);
7071 gfc_add_expr_to_block (&se
->pre
, tmp
);
7073 /* Set the result value. */
7075 se
->string_length
= dlen
;
7079 /* Generate code for the IARGC intrinsic. */
7082 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7088 /* Call the library function. This always returns an INTEGER(4). */
7089 fndecl
= gfor_fndecl_iargc
;
7090 tmp
= build_call_expr_loc (input_location
,
7093 /* Convert it to the required type. */
7094 type
= gfc_typenode_for_spec (&expr
->ts
);
7095 tmp
= fold_convert (type
, tmp
);
7101 /* The loc intrinsic returns the address of its argument as
7102 gfc_index_integer_kind integer. */
7105 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7110 gcc_assert (!se
->ss
);
7112 arg_expr
= expr
->value
.function
.actual
->expr
;
7113 if (arg_expr
->rank
== 0)
7115 if (arg_expr
->ts
.type
== BT_CLASS
)
7116 gfc_add_component_ref (arg_expr
, "_data");
7117 gfc_conv_expr_reference (se
, arg_expr
);
7120 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7121 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7123 /* Create a temporary variable for loc return value. Without this,
7124 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7125 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7126 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7127 se
->expr
= temp_var
;
7131 /* The following routine generates code for the intrinsic
7132 functions from the ISO_C_BINDING module:
7138 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7140 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7142 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7144 if (arg
->expr
->rank
== 0)
7145 gfc_conv_expr_reference (se
, arg
->expr
);
7146 else if (gfc_is_simply_contiguous (arg
->expr
, false))
7147 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7150 gfc_conv_expr_descriptor (se
, arg
->expr
);
7151 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7154 /* TODO -- the following two lines shouldn't be necessary, but if
7155 they're removed, a bug is exposed later in the code path.
7156 This workaround was thus introduced, but will have to be
7157 removed; please see PR 35150 for details about the issue. */
7158 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7159 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7161 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7162 gfc_conv_expr_reference (se
, arg
->expr
);
7163 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7168 /* Build the addr_expr for the first argument. The argument is
7169 already an *address* so we don't need to set want_pointer in
7171 gfc_init_se (&arg1se
, NULL
);
7172 gfc_conv_expr (&arg1se
, arg
->expr
);
7173 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7174 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7176 /* See if we were given two arguments. */
7177 if (arg
->next
->expr
== NULL
)
7178 /* Only given one arg so generate a null and do a
7179 not-equal comparison against the first arg. */
7180 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7182 fold_convert (TREE_TYPE (arg1se
.expr
),
7183 null_pointer_node
));
7189 /* Given two arguments so build the arg2se from second arg. */
7190 gfc_init_se (&arg2se
, NULL
);
7191 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7192 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7193 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7195 /* Generate test to compare that the two args are equal. */
7196 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7197 arg1se
.expr
, arg2se
.expr
);
7198 /* Generate test to ensure that the first arg is not null. */
7199 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7201 arg1se
.expr
, null_pointer_node
);
7203 /* Finally, the generated test must check that both arg1 is not
7204 NULL and that it is equal to the second arg. */
7205 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7207 not_null_expr
, eq_expr
);
7215 /* The following routine generates code for the intrinsic
7216 subroutines from the ISO_C_BINDING module:
7218 * C_F_PROCPOINTER. */
7221 conv_isocbinding_subroutine (gfc_code
*code
)
7228 tree desc
, dim
, tmp
, stride
, offset
;
7229 stmtblock_t body
, block
;
7231 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7233 gfc_init_se (&se
, NULL
);
7234 gfc_init_se (&cptrse
, NULL
);
7235 gfc_conv_expr (&cptrse
, arg
->expr
);
7236 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7237 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7239 gfc_init_se (&fptrse
, NULL
);
7240 if (arg
->next
->expr
->rank
== 0)
7242 fptrse
.want_pointer
= 1;
7243 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7244 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7245 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7246 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7247 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7248 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7250 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7251 TREE_TYPE (fptrse
.expr
),
7253 fold_convert (TREE_TYPE (fptrse
.expr
),
7255 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7256 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7257 return gfc_finish_block (&se
.pre
);
7260 gfc_start_block (&block
);
7262 /* Get the descriptor of the Fortran pointer. */
7263 fptrse
.descriptor_only
= 1;
7264 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7265 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7268 /* Set data value, dtype, and offset. */
7269 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7270 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7271 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7272 gfc_get_dtype (TREE_TYPE (desc
)));
7274 /* Start scalarization of the bounds, using the shape argument. */
7276 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7277 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7278 gfc_init_se (&shapese
, NULL
);
7280 gfc_init_loopinfo (&loop
);
7281 gfc_add_ss_to_loop (&loop
, shape_ss
);
7282 gfc_conv_ss_startstride (&loop
);
7283 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7284 gfc_mark_ss_chain_used (shape_ss
, 1);
7286 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7287 shapese
.ss
= shape_ss
;
7289 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7290 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7291 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7292 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7295 gfc_start_scalarized_body (&loop
, &body
);
7297 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7298 loop
.loopvar
[0], loop
.from
[0]);
7300 /* Set bounds and stride. */
7301 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7302 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7304 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7305 gfc_add_block_to_block (&body
, &shapese
.pre
);
7306 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7307 gfc_add_block_to_block (&body
, &shapese
.post
);
7309 /* Calculate offset. */
7310 gfc_add_modify (&body
, offset
,
7311 fold_build2_loc (input_location
, PLUS_EXPR
,
7312 gfc_array_index_type
, offset
, stride
));
7313 /* Update stride. */
7314 gfc_add_modify (&body
, stride
,
7315 fold_build2_loc (input_location
, MULT_EXPR
,
7316 gfc_array_index_type
, stride
,
7317 fold_convert (gfc_array_index_type
,
7319 /* Finish scalarization loop. */
7320 gfc_trans_scalarizing_loops (&loop
, &body
);
7321 gfc_add_block_to_block (&block
, &loop
.pre
);
7322 gfc_add_block_to_block (&block
, &loop
.post
);
7323 gfc_add_block_to_block (&block
, &fptrse
.post
);
7324 gfc_cleanup_loop (&loop
);
7326 gfc_add_modify (&block
, offset
,
7327 fold_build1_loc (input_location
, NEGATE_EXPR
,
7328 gfc_array_index_type
, offset
));
7329 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7331 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7332 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7333 return gfc_finish_block (&se
.pre
);
7337 /* Save and restore floating-point state. */
7340 gfc_save_fp_state (stmtblock_t
*block
)
7342 tree type
, fpstate
, tmp
;
7344 type
= build_array_type (char_type_node
,
7345 build_range_type (size_type_node
, size_zero_node
,
7346 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
7347 fpstate
= gfc_create_var (type
, "fpstate");
7348 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
7350 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
7352 gfc_add_expr_to_block (block
, tmp
);
7359 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
7363 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
7365 gfc_add_expr_to_block (block
, tmp
);
7369 /* Generate code for arguments of IEEE functions. */
7372 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
7375 gfc_actual_arglist
*actual
;
7380 actual
= expr
->value
.function
.actual
;
7381 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
7383 gcc_assert (actual
);
7386 gfc_init_se (&argse
, se
);
7387 gfc_conv_expr_val (&argse
, e
);
7389 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7390 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7391 argarray
[arg
] = argse
.expr
;
7396 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7397 and IEEE_UNORDERED, which translate directly to GCC type-generic
7401 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
7402 enum built_in_function code
, int nargs
)
7405 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
7407 conv_ieee_function_args (se
, expr
, args
, nargs
);
7408 se
->expr
= build_call_expr_loc_array (input_location
,
7409 builtin_decl_explicit (code
),
7411 STRIP_TYPE_NOPS (se
->expr
);
7412 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7416 /* Generate code for IEEE_IS_NORMAL intrinsic:
7417 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7420 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
7422 tree arg
, isnormal
, iszero
;
7424 /* Convert arg, evaluate it only once. */
7425 conv_ieee_function_args (se
, expr
, &arg
, 1);
7426 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7428 isnormal
= build_call_expr_loc (input_location
,
7429 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
7431 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
7432 build_real_from_int_cst (TREE_TYPE (arg
),
7433 integer_zero_node
));
7434 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7435 boolean_type_node
, isnormal
, iszero
);
7436 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7440 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7441 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7444 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
7446 tree arg
, signbit
, isnan
;
7448 /* Convert arg, evaluate it only once. */
7449 conv_ieee_function_args (se
, expr
, &arg
, 1);
7450 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7452 isnan
= build_call_expr_loc (input_location
,
7453 builtin_decl_explicit (BUILT_IN_ISNAN
),
7455 STRIP_TYPE_NOPS (isnan
);
7457 signbit
= build_call_expr_loc (input_location
,
7458 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7460 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7461 signbit
, integer_zero_node
);
7463 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7464 boolean_type_node
, signbit
,
7465 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
7466 TREE_TYPE(isnan
), isnan
));
7468 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7472 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7475 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
7476 enum built_in_function code
)
7478 tree arg
, decl
, call
, fpstate
;
7481 conv_ieee_function_args (se
, expr
, &arg
, 1);
7482 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7483 decl
= builtin_decl_for_precision (code
, argprec
);
7485 /* Save floating-point state. */
7486 fpstate
= gfc_save_fp_state (&se
->pre
);
7488 /* Make the function call. */
7489 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7490 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
7492 /* Restore floating-point state. */
7493 gfc_restore_fp_state (&se
->post
, fpstate
);
7497 /* Generate code for IEEE_REM. */
7500 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
7502 tree args
[2], decl
, call
, fpstate
;
7505 conv_ieee_function_args (se
, expr
, args
, 2);
7507 /* If arguments have unequal size, convert them to the larger. */
7508 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
7509 > TYPE_PRECISION (TREE_TYPE (args
[1])))
7510 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7511 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
7512 > TYPE_PRECISION (TREE_TYPE (args
[0])))
7513 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
7515 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7516 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
7518 /* Save floating-point state. */
7519 fpstate
= gfc_save_fp_state (&se
->pre
);
7521 /* Make the function call. */
7522 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7523 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7525 /* Restore floating-point state. */
7526 gfc_restore_fp_state (&se
->post
, fpstate
);
7530 /* Generate code for IEEE_NEXT_AFTER. */
7533 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
7535 tree args
[2], decl
, call
, fpstate
;
7538 conv_ieee_function_args (se
, expr
, args
, 2);
7540 /* Result has the characteristics of first argument. */
7541 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7542 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7543 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
7545 /* Save floating-point state. */
7546 fpstate
= gfc_save_fp_state (&se
->pre
);
7548 /* Make the function call. */
7549 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7550 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7552 /* Restore floating-point state. */
7553 gfc_restore_fp_state (&se
->post
, fpstate
);
7557 /* Generate code for IEEE_SCALB. */
7560 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
7562 tree args
[2], decl
, call
, huge
, type
;
7565 conv_ieee_function_args (se
, expr
, args
, 2);
7567 /* Result has the characteristics of first argument. */
7568 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7569 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
7571 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
7573 /* We need to fold the integer into the range of a C int. */
7574 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7575 type
= TREE_TYPE (args
[1]);
7577 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
7578 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
7580 huge
= fold_convert (type
, huge
);
7581 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
7583 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
7584 fold_build1_loc (input_location
, NEGATE_EXPR
,
7588 args
[1] = fold_convert (integer_type_node
, args
[1]);
7590 /* Make the function call. */
7591 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7592 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7596 /* Generate code for IEEE_COPY_SIGN. */
7599 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
7601 tree args
[2], decl
, sign
;
7604 conv_ieee_function_args (se
, expr
, args
, 2);
7606 /* Get the sign of the second argument. */
7607 sign
= build_call_expr_loc (input_location
,
7608 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7610 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7611 sign
, integer_zero_node
);
7613 /* Create a value of one, with the right sign. */
7614 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
7616 fold_build1_loc (input_location
, NEGATE_EXPR
,
7620 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
7622 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7623 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
7625 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7629 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7633 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
7635 const char *name
= expr
->value
.function
.name
;
7637 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7639 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
7640 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
7641 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
7642 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
7643 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
7644 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
7645 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
7646 conv_intrinsic_ieee_is_normal (se
, expr
);
7647 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
7648 conv_intrinsic_ieee_is_negative (se
, expr
);
7649 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
7650 conv_intrinsic_ieee_copy_sign (se
, expr
);
7651 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
7652 conv_intrinsic_ieee_scalb (se
, expr
);
7653 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
7654 conv_intrinsic_ieee_next_after (se
, expr
);
7655 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
7656 conv_intrinsic_ieee_rem (se
, expr
);
7657 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
7658 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
7659 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
7660 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
7662 /* It is not among the functions we translate directly. We return
7663 false, so a library function call is emitted. */
7672 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
7675 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
7677 tree arg
, res
, restype
;
7679 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7680 arg
= fold_convert (size_type_node
, arg
);
7681 res
= build_call_expr_loc (input_location
,
7682 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
7683 restype
= gfc_typenode_for_spec (&expr
->ts
);
7684 se
->expr
= fold_convert (restype
, res
);
7688 /* Generate code for an intrinsic function. Some map directly to library
7689 calls, others get special handling. In some cases the name of the function
7690 used depends on the type specifiers. */
7693 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7699 name
= &expr
->value
.function
.name
[2];
7703 lib
= gfc_is_intrinsic_libcall (expr
);
7707 se
->ignore_optional
= 1;
7709 switch (expr
->value
.function
.isym
->id
)
7711 case GFC_ISYM_EOSHIFT
:
7713 case GFC_ISYM_RESHAPE
:
7714 /* For all of those the first argument specifies the type and the
7715 third is optional. */
7716 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7720 gfc_conv_intrinsic_funcall (se
, expr
);
7728 switch (expr
->value
.function
.isym
->id
)
7733 case GFC_ISYM_REPEAT
:
7734 gfc_conv_intrinsic_repeat (se
, expr
);
7738 gfc_conv_intrinsic_trim (se
, expr
);
7741 case GFC_ISYM_SC_KIND
:
7742 gfc_conv_intrinsic_sc_kind (se
, expr
);
7745 case GFC_ISYM_SI_KIND
:
7746 gfc_conv_intrinsic_si_kind (se
, expr
);
7749 case GFC_ISYM_SR_KIND
:
7750 gfc_conv_intrinsic_sr_kind (se
, expr
);
7753 case GFC_ISYM_EXPONENT
:
7754 gfc_conv_intrinsic_exponent (se
, expr
);
7758 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7760 fndecl
= gfor_fndecl_string_scan
;
7762 fndecl
= gfor_fndecl_string_scan_char4
;
7766 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7769 case GFC_ISYM_VERIFY
:
7770 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7772 fndecl
= gfor_fndecl_string_verify
;
7774 fndecl
= gfor_fndecl_string_verify_char4
;
7778 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7781 case GFC_ISYM_ALLOCATED
:
7782 gfc_conv_allocated (se
, expr
);
7785 case GFC_ISYM_ASSOCIATED
:
7786 gfc_conv_associated(se
, expr
);
7789 case GFC_ISYM_SAME_TYPE_AS
:
7790 gfc_conv_same_type_as (se
, expr
);
7794 gfc_conv_intrinsic_abs (se
, expr
);
7797 case GFC_ISYM_ADJUSTL
:
7798 if (expr
->ts
.kind
== 1)
7799 fndecl
= gfor_fndecl_adjustl
;
7800 else if (expr
->ts
.kind
== 4)
7801 fndecl
= gfor_fndecl_adjustl_char4
;
7805 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7808 case GFC_ISYM_ADJUSTR
:
7809 if (expr
->ts
.kind
== 1)
7810 fndecl
= gfor_fndecl_adjustr
;
7811 else if (expr
->ts
.kind
== 4)
7812 fndecl
= gfor_fndecl_adjustr_char4
;
7816 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7819 case GFC_ISYM_AIMAG
:
7820 gfc_conv_intrinsic_imagpart (se
, expr
);
7824 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7828 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7831 case GFC_ISYM_ANINT
:
7832 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7836 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7840 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7843 case GFC_ISYM_BTEST
:
7844 gfc_conv_intrinsic_btest (se
, expr
);
7848 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7852 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7856 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7860 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7863 case GFC_ISYM_C_ASSOCIATED
:
7864 case GFC_ISYM_C_FUNLOC
:
7865 case GFC_ISYM_C_LOC
:
7866 conv_isocbinding_function (se
, expr
);
7869 case GFC_ISYM_ACHAR
:
7871 gfc_conv_intrinsic_char (se
, expr
);
7874 case GFC_ISYM_CONVERSION
:
7876 case GFC_ISYM_LOGICAL
:
7878 gfc_conv_intrinsic_conversion (se
, expr
);
7881 /* Integer conversions are handled separately to make sure we get the
7882 correct rounding mode. */
7887 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7891 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7894 case GFC_ISYM_CEILING
:
7895 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7898 case GFC_ISYM_FLOOR
:
7899 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7903 gfc_conv_intrinsic_mod (se
, expr
, 0);
7906 case GFC_ISYM_MODULO
:
7907 gfc_conv_intrinsic_mod (se
, expr
, 1);
7910 case GFC_ISYM_CAF_GET
:
7911 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
);
7914 case GFC_ISYM_CMPLX
:
7915 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7918 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7919 gfc_conv_intrinsic_iargc (se
, expr
);
7922 case GFC_ISYM_COMPLEX
:
7923 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7926 case GFC_ISYM_CONJG
:
7927 gfc_conv_intrinsic_conjg (se
, expr
);
7930 case GFC_ISYM_COUNT
:
7931 gfc_conv_intrinsic_count (se
, expr
);
7934 case GFC_ISYM_CTIME
:
7935 gfc_conv_intrinsic_ctime (se
, expr
);
7939 gfc_conv_intrinsic_dim (se
, expr
);
7942 case GFC_ISYM_DOT_PRODUCT
:
7943 gfc_conv_intrinsic_dot_product (se
, expr
);
7946 case GFC_ISYM_DPROD
:
7947 gfc_conv_intrinsic_dprod (se
, expr
);
7950 case GFC_ISYM_DSHIFTL
:
7951 gfc_conv_intrinsic_dshift (se
, expr
, true);
7954 case GFC_ISYM_DSHIFTR
:
7955 gfc_conv_intrinsic_dshift (se
, expr
, false);
7958 case GFC_ISYM_FDATE
:
7959 gfc_conv_intrinsic_fdate (se
, expr
);
7962 case GFC_ISYM_FRACTION
:
7963 gfc_conv_intrinsic_fraction (se
, expr
);
7967 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7971 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7975 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
7978 case GFC_ISYM_IBCLR
:
7979 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
7982 case GFC_ISYM_IBITS
:
7983 gfc_conv_intrinsic_ibits (se
, expr
);
7986 case GFC_ISYM_IBSET
:
7987 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
7990 case GFC_ISYM_IACHAR
:
7991 case GFC_ISYM_ICHAR
:
7992 /* We assume ASCII character sequence. */
7993 gfc_conv_intrinsic_ichar (se
, expr
);
7996 case GFC_ISYM_IARGC
:
7997 gfc_conv_intrinsic_iargc (se
, expr
);
8001 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8004 case GFC_ISYM_INDEX
:
8005 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8007 fndecl
= gfor_fndecl_string_index
;
8009 fndecl
= gfor_fndecl_string_index_char4
;
8013 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8017 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8020 case GFC_ISYM_IPARITY
:
8021 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8024 case GFC_ISYM_IS_IOSTAT_END
:
8025 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8028 case GFC_ISYM_IS_IOSTAT_EOR
:
8029 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8032 case GFC_ISYM_ISNAN
:
8033 gfc_conv_intrinsic_isnan (se
, expr
);
8036 case GFC_ISYM_LSHIFT
:
8037 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8040 case GFC_ISYM_RSHIFT
:
8041 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8044 case GFC_ISYM_SHIFTA
:
8045 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8048 case GFC_ISYM_SHIFTL
:
8049 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8052 case GFC_ISYM_SHIFTR
:
8053 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8056 case GFC_ISYM_ISHFT
:
8057 gfc_conv_intrinsic_ishft (se
, expr
);
8060 case GFC_ISYM_ISHFTC
:
8061 gfc_conv_intrinsic_ishftc (se
, expr
);
8064 case GFC_ISYM_LEADZ
:
8065 gfc_conv_intrinsic_leadz (se
, expr
);
8068 case GFC_ISYM_TRAILZ
:
8069 gfc_conv_intrinsic_trailz (se
, expr
);
8072 case GFC_ISYM_POPCNT
:
8073 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8076 case GFC_ISYM_POPPAR
:
8077 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8080 case GFC_ISYM_LBOUND
:
8081 gfc_conv_intrinsic_bound (se
, expr
, 0);
8084 case GFC_ISYM_LCOBOUND
:
8085 conv_intrinsic_cobound (se
, expr
);
8088 case GFC_ISYM_TRANSPOSE
:
8089 /* The scalarizer has already been set up for reversed dimension access
8090 order ; now we just get the argument value normally. */
8091 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8095 gfc_conv_intrinsic_len (se
, expr
);
8098 case GFC_ISYM_LEN_TRIM
:
8099 gfc_conv_intrinsic_len_trim (se
, expr
);
8103 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8107 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8111 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8115 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8118 case GFC_ISYM_MALLOC
:
8119 gfc_conv_intrinsic_malloc (se
, expr
);
8122 case GFC_ISYM_MASKL
:
8123 gfc_conv_intrinsic_mask (se
, expr
, 1);
8126 case GFC_ISYM_MASKR
:
8127 gfc_conv_intrinsic_mask (se
, expr
, 0);
8131 if (expr
->ts
.type
== BT_CHARACTER
)
8132 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8134 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8137 case GFC_ISYM_MAXLOC
:
8138 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8141 case GFC_ISYM_MAXVAL
:
8142 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8145 case GFC_ISYM_MERGE
:
8146 gfc_conv_intrinsic_merge (se
, expr
);
8149 case GFC_ISYM_MERGE_BITS
:
8150 gfc_conv_intrinsic_merge_bits (se
, expr
);
8154 if (expr
->ts
.type
== BT_CHARACTER
)
8155 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8157 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8160 case GFC_ISYM_MINLOC
:
8161 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8164 case GFC_ISYM_MINVAL
:
8165 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8168 case GFC_ISYM_NEAREST
:
8169 gfc_conv_intrinsic_nearest (se
, expr
);
8172 case GFC_ISYM_NORM2
:
8173 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8177 gfc_conv_intrinsic_not (se
, expr
);
8181 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8184 case GFC_ISYM_PARITY
:
8185 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8188 case GFC_ISYM_PRESENT
:
8189 gfc_conv_intrinsic_present (se
, expr
);
8192 case GFC_ISYM_PRODUCT
:
8193 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8197 gfc_conv_intrinsic_rank (se
, expr
);
8200 case GFC_ISYM_RRSPACING
:
8201 gfc_conv_intrinsic_rrspacing (se
, expr
);
8204 case GFC_ISYM_SET_EXPONENT
:
8205 gfc_conv_intrinsic_set_exponent (se
, expr
);
8208 case GFC_ISYM_SCALE
:
8209 gfc_conv_intrinsic_scale (se
, expr
);
8213 gfc_conv_intrinsic_sign (se
, expr
);
8217 gfc_conv_intrinsic_size (se
, expr
);
8220 case GFC_ISYM_SIZEOF
:
8221 case GFC_ISYM_C_SIZEOF
:
8222 gfc_conv_intrinsic_sizeof (se
, expr
);
8225 case GFC_ISYM_STORAGE_SIZE
:
8226 gfc_conv_intrinsic_storage_size (se
, expr
);
8229 case GFC_ISYM_SPACING
:
8230 gfc_conv_intrinsic_spacing (se
, expr
);
8233 case GFC_ISYM_STRIDE
:
8234 conv_intrinsic_stride (se
, expr
);
8238 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8241 case GFC_ISYM_TRANSFER
:
8242 if (se
->ss
&& se
->ss
->info
->useflags
)
8243 /* Access the previously obtained result. */
8244 gfc_conv_tmp_array_ref (se
);
8246 gfc_conv_intrinsic_transfer (se
, expr
);
8249 case GFC_ISYM_TTYNAM
:
8250 gfc_conv_intrinsic_ttynam (se
, expr
);
8253 case GFC_ISYM_UBOUND
:
8254 gfc_conv_intrinsic_bound (se
, expr
, 1);
8257 case GFC_ISYM_UCOBOUND
:
8258 conv_intrinsic_cobound (se
, expr
);
8262 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8266 gfc_conv_intrinsic_loc (se
, expr
);
8269 case GFC_ISYM_THIS_IMAGE
:
8270 /* For num_images() == 1, handle as LCOBOUND. */
8271 if (expr
->value
.function
.actual
->expr
8272 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
8273 conv_intrinsic_cobound (se
, expr
);
8275 trans_this_image (se
, expr
);
8278 case GFC_ISYM_IMAGE_INDEX
:
8279 trans_image_index (se
, expr
);
8282 case GFC_ISYM_NUM_IMAGES
:
8283 trans_num_images (se
, expr
);
8286 case GFC_ISYM_ACCESS
:
8287 case GFC_ISYM_CHDIR
:
8288 case GFC_ISYM_CHMOD
:
8289 case GFC_ISYM_DTIME
:
8290 case GFC_ISYM_ETIME
:
8291 case GFC_ISYM_EXTENDS_TYPE_OF
:
8293 case GFC_ISYM_FGETC
:
8296 case GFC_ISYM_FPUTC
:
8297 case GFC_ISYM_FSTAT
:
8298 case GFC_ISYM_FTELL
:
8299 case GFC_ISYM_GETCWD
:
8300 case GFC_ISYM_GETGID
:
8301 case GFC_ISYM_GETPID
:
8302 case GFC_ISYM_GETUID
:
8303 case GFC_ISYM_HOSTNM
:
8305 case GFC_ISYM_IERRNO
:
8306 case GFC_ISYM_IRAND
:
8307 case GFC_ISYM_ISATTY
:
8310 case GFC_ISYM_LSTAT
:
8311 case GFC_ISYM_MATMUL
:
8312 case GFC_ISYM_MCLOCK
:
8313 case GFC_ISYM_MCLOCK8
:
8315 case GFC_ISYM_RENAME
:
8316 case GFC_ISYM_SECOND
:
8317 case GFC_ISYM_SECNDS
:
8318 case GFC_ISYM_SIGNAL
:
8320 case GFC_ISYM_SYMLNK
:
8321 case GFC_ISYM_SYSTEM
:
8323 case GFC_ISYM_TIME8
:
8324 case GFC_ISYM_UMASK
:
8325 case GFC_ISYM_UNLINK
:
8327 gfc_conv_intrinsic_funcall (se
, expr
);
8330 case GFC_ISYM_EOSHIFT
:
8332 case GFC_ISYM_RESHAPE
:
8333 /* For those, expr->rank should always be >0 and thus the if above the
8334 switch should have matched. */
8339 gfc_conv_intrinsic_lib_function (se
, expr
);
8346 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
8348 gfc_ss
*arg_ss
, *tmp_ss
;
8349 gfc_actual_arglist
*arg
;
8351 arg
= expr
->value
.function
.actual
;
8353 gcc_assert (arg
->expr
);
8355 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
8356 gcc_assert (arg_ss
!= gfc_ss_terminator
);
8358 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
8360 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
8361 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
8363 gcc_assert (tmp_ss
->dimen
== 2);
8365 /* We just invert dimensions. */
8366 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
8369 /* Stop when tmp_ss points to the last valid element of the chain... */
8370 if (tmp_ss
->next
== gfc_ss_terminator
)
8374 /* ... so that we can attach the rest of the chain to it. */
8381 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8382 This has the side effect of reversing the nested list, so there is no
8383 need to call gfc_reverse_ss on it (the given list is assumed not to be
8387 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8390 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8391 gfc_loopinfo
*new_loop
;
8393 gcc_assert (ss
!= gfc_ss_terminator
);
8395 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8397 new_ss
= gfc_get_ss ();
8398 new_ss
->next
= prev_ss
;
8399 new_ss
->parent
= ss
;
8400 new_ss
->info
= ss
->info
;
8401 new_ss
->info
->refcount
++;
8404 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8405 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8408 new_ss
->dim
[0] = ss
->dim
[dim
];
8410 gcc_assert (dim
< ss
->dimen
);
8412 ss_dim
= --ss
->dimen
;
8413 for (i
= dim
; i
< ss_dim
; i
++)
8414 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8416 ss
->dim
[ss_dim
] = 0;
8422 ss
->nested_ss
->parent
= new_ss
;
8423 new_ss
->nested_ss
= ss
->nested_ss
;
8425 ss
->nested_ss
= new_ss
;
8428 new_loop
= gfc_get_loopinfo ();
8429 gfc_init_loopinfo (new_loop
);
8431 gcc_assert (prev_ss
!= NULL
);
8432 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8433 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8434 return new_ss
->parent
;
8438 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8439 is to be inlined. */
8442 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8444 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8445 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8447 bool scalar_mask
= false;
8449 /* The rank of the result will be determined later. */
8450 arg1
= expr
->value
.function
.actual
;
8453 gcc_assert (arg3
!= NULL
);
8455 if (expr
->rank
== 0)
8458 tmp_ss
= gfc_ss_terminator
;
8464 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8465 if (mask_ss
== tmp_ss
)
8471 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8472 gcc_assert (array_ss
!= tmp_ss
);
8474 /* Odd thing: If the mask is scalar, it is used by the frontend after
8475 the array (to make an if around the nested loop). Thus it shall
8476 be after array_ss once the gfc_ss list is reversed. */
8478 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8482 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8484 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8485 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8493 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8496 switch (expr
->value
.function
.isym
->id
)
8498 case GFC_ISYM_PRODUCT
:
8500 return walk_inline_intrinsic_arith (ss
, expr
);
8502 case GFC_ISYM_TRANSPOSE
:
8503 return walk_inline_intrinsic_transpose (ss
, expr
);
8512 /* This generates code to execute before entering the scalarization loop.
8513 Currently does nothing. */
8516 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8518 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8520 case GFC_ISYM_UBOUND
:
8521 case GFC_ISYM_LBOUND
:
8522 case GFC_ISYM_UCOBOUND
:
8523 case GFC_ISYM_LCOBOUND
:
8524 case GFC_ISYM_THIS_IMAGE
:
8533 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8534 are expanded into code inside the scalarization loop. */
8537 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8539 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8540 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8542 /* The two argument version returns a scalar. */
8543 if (expr
->value
.function
.actual
->next
->expr
)
8546 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8550 /* Walk an intrinsic array libcall. */
8553 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8555 gcc_assert (expr
->rank
> 0);
8556 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8560 /* Return whether the function call expression EXPR will be expanded
8561 inline by gfc_conv_intrinsic_function. */
8564 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8566 gfc_actual_arglist
*args
;
8568 if (!expr
->value
.function
.isym
)
8571 switch (expr
->value
.function
.isym
->id
)
8573 case GFC_ISYM_PRODUCT
:
8575 /* Disable inline expansion if code size matters. */
8579 args
= expr
->value
.function
.actual
;
8580 /* We need to be able to subset the SUM argument at compile-time. */
8581 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8586 case GFC_ISYM_TRANSPOSE
:
8595 /* Returns nonzero if the specified intrinsic function call maps directly to
8596 an external library call. Should only be used for functions that return
8600 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8602 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8603 gcc_assert (expr
->rank
> 0);
8605 if (gfc_inline_intrinsic_function_p (expr
))
8608 switch (expr
->value
.function
.isym
->id
)
8612 case GFC_ISYM_COUNT
:
8616 case GFC_ISYM_IPARITY
:
8617 case GFC_ISYM_MATMUL
:
8618 case GFC_ISYM_MAXLOC
:
8619 case GFC_ISYM_MAXVAL
:
8620 case GFC_ISYM_MINLOC
:
8621 case GFC_ISYM_MINVAL
:
8622 case GFC_ISYM_NORM2
:
8623 case GFC_ISYM_PARITY
:
8624 case GFC_ISYM_PRODUCT
:
8626 case GFC_ISYM_SHAPE
:
8627 case GFC_ISYM_SPREAD
:
8629 /* Ignore absent optional parameters. */
8632 case GFC_ISYM_RESHAPE
:
8633 case GFC_ISYM_CSHIFT
:
8634 case GFC_ISYM_EOSHIFT
:
8636 case GFC_ISYM_UNPACK
:
8637 /* Pass absent optional parameters. */
8645 /* Walk an intrinsic function. */
8647 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8648 gfc_intrinsic_sym
* isym
)
8652 if (isym
->elemental
)
8653 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8654 NULL
, GFC_SS_SCALAR
);
8656 if (expr
->rank
== 0)
8659 if (gfc_inline_intrinsic_function_p (expr
))
8660 return walk_inline_intrinsic_function (ss
, expr
);
8662 if (gfc_is_intrinsic_libcall (expr
))
8663 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8665 /* Special cases. */
8668 case GFC_ISYM_LBOUND
:
8669 case GFC_ISYM_LCOBOUND
:
8670 case GFC_ISYM_UBOUND
:
8671 case GFC_ISYM_UCOBOUND
:
8672 case GFC_ISYM_THIS_IMAGE
:
8673 return gfc_walk_intrinsic_bound (ss
, expr
);
8675 case GFC_ISYM_TRANSFER
:
8676 case GFC_ISYM_CAF_GET
:
8677 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8680 /* This probably meant someone forgot to add an intrinsic to the above
8681 list(s) when they implemented it, or something's gone horribly
8689 conv_co_collective (gfc_code
*code
)
8692 stmtblock_t block
, post_block
;
8693 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8694 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
8696 gfc_start_block (&block
);
8697 gfc_init_block (&post_block
);
8699 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
8701 opr_expr
= code
->ext
.actual
->next
->expr
;
8702 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
8703 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8704 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
8709 image_idx_expr
= code
->ext
.actual
->next
->expr
;
8710 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8711 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8717 gfc_init_se (&argse
, NULL
);
8718 gfc_conv_expr (&argse
, stat_expr
);
8719 gfc_add_block_to_block (&block
, &argse
.pre
);
8720 gfc_add_block_to_block (&post_block
, &argse
.post
);
8722 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8723 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8725 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8728 stat
= null_pointer_node
;
8730 /* Early exit for GFC_FCOARRAY_SINGLE. */
8731 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8733 if (stat
!= NULL_TREE
)
8734 gfc_add_modify (&block
, stat
,
8735 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8736 return gfc_finish_block (&block
);
8739 /* Handle the array. */
8740 gfc_init_se (&argse
, NULL
);
8741 if (code
->ext
.actual
->expr
->rank
== 0)
8743 symbol_attribute attr
;
8744 gfc_clear_attr (&attr
);
8745 gfc_init_se (&argse
, NULL
);
8746 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8747 gfc_add_block_to_block (&block
, &argse
.pre
);
8748 gfc_add_block_to_block (&post_block
, &argse
.post
);
8749 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8750 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8754 argse
.want_pointer
= 1;
8755 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8758 gfc_add_block_to_block (&block
, &argse
.pre
);
8759 gfc_add_block_to_block (&post_block
, &argse
.post
);
8761 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8762 strlen
= argse
.string_length
;
8764 strlen
= integer_zero_node
;
8769 gfc_init_se (&argse
, NULL
);
8770 gfc_conv_expr (&argse
, image_idx_expr
);
8771 gfc_add_block_to_block (&block
, &argse
.pre
);
8772 gfc_add_block_to_block (&post_block
, &argse
.post
);
8773 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8776 image_index
= integer_zero_node
;
8781 gfc_init_se (&argse
, NULL
);
8782 gfc_conv_expr (&argse
, errmsg_expr
);
8783 gfc_add_block_to_block (&block
, &argse
.pre
);
8784 gfc_add_block_to_block (&post_block
, &argse
.post
);
8785 errmsg
= argse
.expr
;
8786 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8790 errmsg
= null_pointer_node
;
8791 errmsg_len
= integer_zero_node
;
8794 /* Generate the function call. */
8795 switch (code
->resolved_isym
->id
)
8797 case GFC_ISYM_CO_BROADCAST
:
8798 fndecl
= gfor_fndecl_co_broadcast
;
8800 case GFC_ISYM_CO_MAX
:
8801 fndecl
= gfor_fndecl_co_max
;
8803 case GFC_ISYM_CO_MIN
:
8804 fndecl
= gfor_fndecl_co_min
;
8806 case GFC_ISYM_CO_REDUCE
:
8807 fndecl
= gfor_fndecl_co_reduce
;
8809 case GFC_ISYM_CO_SUM
:
8810 fndecl
= gfor_fndecl_co_sum
;
8816 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
8817 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
8818 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8819 image_index
, stat
, errmsg
, errmsg_len
);
8820 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
8821 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8822 stat
, errmsg
, strlen
, errmsg_len
);
8825 tree opr
, opr_flags
;
8827 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8829 if (gfc_is_proc_ptr_comp (opr_expr
))
8831 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
8832 opr_flag_int
= sym
->attr
.dimension
8833 || (sym
->ts
.type
== BT_CHARACTER
8834 && !sym
->attr
.is_bind_c
)
8835 ? GFC_CAF_BYREF
: 0;
8836 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8837 && !sym
->attr
.is_bind_c
8838 ? GFC_CAF_HIDDENLEN
: 0;
8839 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
8843 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
8844 ? GFC_CAF_BYREF
: 0;
8845 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8846 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
8847 ? GFC_CAF_HIDDENLEN
: 0;
8848 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
8849 ? GFC_CAF_ARG_VALUE
: 0;
8851 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
8852 gfc_conv_expr (&argse
, opr_expr
);
8854 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
8855 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
8858 gfc_add_expr_to_block (&block
, fndecl
);
8859 gfc_add_block_to_block (&block
, &post_block
);
8861 return gfc_finish_block (&block
);
8866 conv_intrinsic_atomic_op (gfc_code
*code
)
8869 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8870 stmtblock_t block
, post_block
;
8871 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8872 gfc_expr
*stat_expr
;
8873 built_in_function fn
;
8875 if (atom_expr
->expr_type
== EXPR_FUNCTION
8876 && atom_expr
->value
.function
.isym
8877 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8878 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8880 gfc_start_block (&block
);
8881 gfc_init_block (&post_block
);
8883 gfc_init_se (&argse
, NULL
);
8884 argse
.want_pointer
= 1;
8885 gfc_conv_expr (&argse
, atom_expr
);
8886 gfc_add_block_to_block (&block
, &argse
.pre
);
8887 gfc_add_block_to_block (&post_block
, &argse
.post
);
8890 gfc_init_se (&argse
, NULL
);
8891 if (flag_coarray
== GFC_FCOARRAY_LIB
8892 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8893 argse
.want_pointer
= 1;
8894 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8895 gfc_add_block_to_block (&block
, &argse
.pre
);
8896 gfc_add_block_to_block (&post_block
, &argse
.post
);
8899 switch (code
->resolved_isym
->id
)
8901 case GFC_ISYM_ATOMIC_ADD
:
8902 case GFC_ISYM_ATOMIC_AND
:
8903 case GFC_ISYM_ATOMIC_DEF
:
8904 case GFC_ISYM_ATOMIC_OR
:
8905 case GFC_ISYM_ATOMIC_XOR
:
8906 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8907 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8908 old
= null_pointer_node
;
8911 gfc_init_se (&argse
, NULL
);
8912 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8913 argse
.want_pointer
= 1;
8914 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8915 gfc_add_block_to_block (&block
, &argse
.pre
);
8916 gfc_add_block_to_block (&post_block
, &argse
.post
);
8918 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8922 if (stat_expr
!= NULL
)
8924 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8925 gfc_init_se (&argse
, NULL
);
8926 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8927 argse
.want_pointer
= 1;
8928 gfc_conv_expr_val (&argse
, stat_expr
);
8929 gfc_add_block_to_block (&block
, &argse
.pre
);
8930 gfc_add_block_to_block (&post_block
, &argse
.post
);
8933 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
8934 stat
= null_pointer_node
;
8936 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8938 tree image_index
, caf_decl
, offset
, token
;
8941 switch (code
->resolved_isym
->id
)
8943 case GFC_ISYM_ATOMIC_ADD
:
8944 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8945 op
= (int) GFC_CAF_ATOMIC_ADD
;
8947 case GFC_ISYM_ATOMIC_AND
:
8948 case GFC_ISYM_ATOMIC_FETCH_AND
:
8949 op
= (int) GFC_CAF_ATOMIC_AND
;
8951 case GFC_ISYM_ATOMIC_OR
:
8952 case GFC_ISYM_ATOMIC_FETCH_OR
:
8953 op
= (int) GFC_CAF_ATOMIC_OR
;
8955 case GFC_ISYM_ATOMIC_XOR
:
8956 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8957 op
= (int) GFC_CAF_ATOMIC_XOR
;
8959 case GFC_ISYM_ATOMIC_DEF
:
8960 op
= 0; /* Unused. */
8966 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8967 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8968 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8970 if (gfc_is_coindexed (atom_expr
))
8971 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
8973 image_index
= integer_zero_node
;
8975 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
8977 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
8978 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
8979 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8982 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8984 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
8985 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
8986 token
, offset
, image_index
, value
, stat
,
8987 build_int_cst (integer_type_node
,
8988 (int) atom_expr
->ts
.type
),
8989 build_int_cst (integer_type_node
,
8990 (int) atom_expr
->ts
.kind
));
8992 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
8993 build_int_cst (integer_type_node
, op
),
8994 token
, offset
, image_index
, value
, old
, stat
,
8995 build_int_cst (integer_type_node
,
8996 (int) atom_expr
->ts
.type
),
8997 build_int_cst (integer_type_node
,
8998 (int) atom_expr
->ts
.kind
));
9000 gfc_add_expr_to_block (&block
, tmp
);
9001 gfc_add_block_to_block (&block
, &post_block
);
9002 return gfc_finish_block (&block
);
9006 switch (code
->resolved_isym
->id
)
9008 case GFC_ISYM_ATOMIC_ADD
:
9009 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9010 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9012 case GFC_ISYM_ATOMIC_AND
:
9013 case GFC_ISYM_ATOMIC_FETCH_AND
:
9014 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9016 case GFC_ISYM_ATOMIC_DEF
:
9017 fn
= BUILT_IN_ATOMIC_STORE_N
;
9019 case GFC_ISYM_ATOMIC_OR
:
9020 case GFC_ISYM_ATOMIC_FETCH_OR
:
9021 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9023 case GFC_ISYM_ATOMIC_XOR
:
9024 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9025 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9031 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9032 fn
= (built_in_function
) ((int) fn
9033 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9035 tmp
= builtin_decl_explicit (fn
);
9036 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9037 tmp
= builtin_decl_explicit (fn
);
9039 switch (code
->resolved_isym
->id
)
9041 case GFC_ISYM_ATOMIC_ADD
:
9042 case GFC_ISYM_ATOMIC_AND
:
9043 case GFC_ISYM_ATOMIC_DEF
:
9044 case GFC_ISYM_ATOMIC_OR
:
9045 case GFC_ISYM_ATOMIC_XOR
:
9046 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9047 fold_convert (itype
, value
),
9048 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9049 gfc_add_expr_to_block (&block
, tmp
);
9052 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9053 fold_convert (itype
, value
),
9054 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9055 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9059 if (stat
!= NULL_TREE
)
9060 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9061 gfc_add_block_to_block (&block
, &post_block
);
9062 return gfc_finish_block (&block
);
9067 conv_intrinsic_atomic_ref (gfc_code
*code
)
9070 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9071 stmtblock_t block
, post_block
;
9072 built_in_function fn
;
9073 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9075 if (atom_expr
->expr_type
== EXPR_FUNCTION
9076 && atom_expr
->value
.function
.isym
9077 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9078 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9080 gfc_start_block (&block
);
9081 gfc_init_block (&post_block
);
9082 gfc_init_se (&argse
, NULL
);
9083 argse
.want_pointer
= 1;
9084 gfc_conv_expr (&argse
, atom_expr
);
9085 gfc_add_block_to_block (&block
, &argse
.pre
);
9086 gfc_add_block_to_block (&post_block
, &argse
.post
);
9089 gfc_init_se (&argse
, NULL
);
9090 if (flag_coarray
== GFC_FCOARRAY_LIB
9091 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9092 argse
.want_pointer
= 1;
9093 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9094 gfc_add_block_to_block (&block
, &argse
.pre
);
9095 gfc_add_block_to_block (&post_block
, &argse
.post
);
9099 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9101 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9103 gfc_init_se (&argse
, NULL
);
9104 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9105 argse
.want_pointer
= 1;
9106 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9107 gfc_add_block_to_block (&block
, &argse
.pre
);
9108 gfc_add_block_to_block (&post_block
, &argse
.post
);
9111 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9112 stat
= null_pointer_node
;
9114 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9116 tree image_index
, caf_decl
, offset
, token
;
9117 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9119 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9120 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9121 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9123 if (gfc_is_coindexed (atom_expr
))
9124 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9126 image_index
= integer_zero_node
;
9128 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9130 /* Different type, need type conversion. */
9131 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9133 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9135 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9138 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9139 token
, offset
, image_index
, value
, stat
,
9140 build_int_cst (integer_type_node
,
9141 (int) atom_expr
->ts
.type
),
9142 build_int_cst (integer_type_node
,
9143 (int) atom_expr
->ts
.kind
));
9144 gfc_add_expr_to_block (&block
, tmp
);
9145 if (vardecl
!= NULL_TREE
)
9146 gfc_add_modify (&block
, orig_value
,
9147 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9148 gfc_add_block_to_block (&block
, &post_block
);
9149 return gfc_finish_block (&block
);
9152 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9153 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9154 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9156 tmp
= builtin_decl_explicit (fn
);
9157 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9158 build_int_cst (integer_type_node
,
9160 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9162 if (stat
!= NULL_TREE
)
9163 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9164 gfc_add_block_to_block (&block
, &post_block
);
9165 return gfc_finish_block (&block
);
9170 conv_intrinsic_atomic_cas (gfc_code
*code
)
9173 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9174 stmtblock_t block
, post_block
;
9175 built_in_function fn
;
9176 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9178 if (atom_expr
->expr_type
== EXPR_FUNCTION
9179 && atom_expr
->value
.function
.isym
9180 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9181 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9183 gfc_init_block (&block
);
9184 gfc_init_block (&post_block
);
9185 gfc_init_se (&argse
, NULL
);
9186 argse
.want_pointer
= 1;
9187 gfc_conv_expr (&argse
, atom_expr
);
9190 gfc_init_se (&argse
, NULL
);
9191 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9192 argse
.want_pointer
= 1;
9193 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9194 gfc_add_block_to_block (&block
, &argse
.pre
);
9195 gfc_add_block_to_block (&post_block
, &argse
.post
);
9198 gfc_init_se (&argse
, NULL
);
9199 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9200 argse
.want_pointer
= 1;
9201 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9202 gfc_add_block_to_block (&block
, &argse
.pre
);
9203 gfc_add_block_to_block (&post_block
, &argse
.post
);
9206 gfc_init_se (&argse
, NULL
);
9207 if (flag_coarray
== GFC_FCOARRAY_LIB
9208 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9209 == atom_expr
->ts
.kind
)
9210 argse
.want_pointer
= 1;
9211 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9212 gfc_add_block_to_block (&block
, &argse
.pre
);
9213 gfc_add_block_to_block (&post_block
, &argse
.post
);
9214 new_val
= argse
.expr
;
9217 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9219 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9221 gfc_init_se (&argse
, NULL
);
9222 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9223 argse
.want_pointer
= 1;
9224 gfc_conv_expr_val (&argse
,
9225 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9226 gfc_add_block_to_block (&block
, &argse
.pre
);
9227 gfc_add_block_to_block (&post_block
, &argse
.post
);
9230 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9231 stat
= null_pointer_node
;
9233 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9235 tree image_index
, caf_decl
, offset
, token
;
9237 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9238 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9239 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9241 if (gfc_is_coindexed (atom_expr
))
9242 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9244 image_index
= integer_zero_node
;
9246 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9248 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9249 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9250 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9253 /* Convert a constant to a pointer. */
9254 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
9256 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
9257 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
9258 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9261 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9263 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
9264 token
, offset
, image_index
, old
, comp
, new_val
,
9265 stat
, build_int_cst (integer_type_node
,
9266 (int) atom_expr
->ts
.type
),
9267 build_int_cst (integer_type_node
,
9268 (int) atom_expr
->ts
.kind
));
9269 gfc_add_expr_to_block (&block
, tmp
);
9270 gfc_add_block_to_block (&block
, &post_block
);
9271 return gfc_finish_block (&block
);
9274 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9275 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9276 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9278 tmp
= builtin_decl_explicit (fn
);
9280 gfc_add_modify (&block
, old
, comp
);
9281 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
9282 gfc_build_addr_expr (NULL
, old
),
9283 fold_convert (TREE_TYPE (old
), new_val
),
9285 build_int_cst (NULL
, MEMMODEL_RELAXED
),
9286 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9287 gfc_add_expr_to_block (&block
, tmp
);
9289 if (stat
!= NULL_TREE
)
9290 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9291 gfc_add_block_to_block (&block
, &post_block
);
9292 return gfc_finish_block (&block
);
9297 conv_intrinsic_move_alloc (gfc_code
*code
)
9300 gfc_expr
*from_expr
, *to_expr
;
9301 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
9302 gfc_se from_se
, to_se
;
9306 gfc_start_block (&block
);
9308 from_expr
= code
->ext
.actual
->expr
;
9309 to_expr
= code
->ext
.actual
->next
->expr
;
9311 gfc_init_se (&from_se
, NULL
);
9312 gfc_init_se (&to_se
, NULL
);
9314 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
9315 || to_expr
->ts
.type
== BT_CLASS
);
9316 coarray
= gfc_get_corank (from_expr
) != 0;
9318 if (from_expr
->rank
== 0 && !coarray
)
9320 if (from_expr
->ts
.type
!= BT_CLASS
)
9321 from_expr2
= from_expr
;
9324 from_expr2
= gfc_copy_expr (from_expr
);
9325 gfc_add_data_component (from_expr2
);
9328 if (to_expr
->ts
.type
!= BT_CLASS
)
9332 to_expr2
= gfc_copy_expr (to_expr
);
9333 gfc_add_data_component (to_expr2
);
9336 from_se
.want_pointer
= 1;
9337 to_se
.want_pointer
= 1;
9338 gfc_conv_expr (&from_se
, from_expr2
);
9339 gfc_conv_expr (&to_se
, to_expr2
);
9340 gfc_add_block_to_block (&block
, &from_se
.pre
);
9341 gfc_add_block_to_block (&block
, &to_se
.pre
);
9343 /* Deallocate "to". */
9344 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
9345 to_expr
, to_expr
->ts
);
9346 gfc_add_expr_to_block (&block
, tmp
);
9348 /* Assign (_data) pointers. */
9349 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9350 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
9352 /* Set "from" to NULL. */
9353 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9354 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
9356 gfc_add_block_to_block (&block
, &from_se
.post
);
9357 gfc_add_block_to_block (&block
, &to_se
.post
);
9360 if (to_expr
->ts
.type
== BT_CLASS
)
9364 gfc_free_expr (to_expr2
);
9365 gfc_init_se (&to_se
, NULL
);
9366 to_se
.want_pointer
= 1;
9367 gfc_add_vptr_component (to_expr
);
9368 gfc_conv_expr (&to_se
, to_expr
);
9370 if (from_expr
->ts
.type
== BT_CLASS
)
9372 if (UNLIMITED_POLY (from_expr
))
9376 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9380 gfc_free_expr (from_expr2
);
9381 gfc_init_se (&from_se
, NULL
);
9382 from_se
.want_pointer
= 1;
9383 gfc_add_vptr_component (from_expr
);
9384 gfc_conv_expr (&from_se
, from_expr
);
9385 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9386 fold_convert (TREE_TYPE (to_se
.expr
),
9389 /* Reset _vptr component to declared type. */
9391 /* Unlimited polymorphic. */
9392 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9393 fold_convert (TREE_TYPE (from_se
.expr
),
9394 null_pointer_node
));
9397 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9398 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9399 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9404 vtab
= gfc_find_vtab (&from_expr
->ts
);
9406 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9407 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9408 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9412 return gfc_finish_block (&block
);
9415 /* Update _vptr component. */
9416 if (to_expr
->ts
.type
== BT_CLASS
)
9420 to_se
.want_pointer
= 1;
9421 to_expr2
= gfc_copy_expr (to_expr
);
9422 gfc_add_vptr_component (to_expr2
);
9423 gfc_conv_expr (&to_se
, to_expr2
);
9425 if (from_expr
->ts
.type
== BT_CLASS
)
9427 if (UNLIMITED_POLY (from_expr
))
9431 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9435 from_se
.want_pointer
= 1;
9436 from_expr2
= gfc_copy_expr (from_expr
);
9437 gfc_add_vptr_component (from_expr2
);
9438 gfc_conv_expr (&from_se
, from_expr2
);
9439 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9440 fold_convert (TREE_TYPE (to_se
.expr
),
9443 /* Reset _vptr component to declared type. */
9445 /* Unlimited polymorphic. */
9446 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9447 fold_convert (TREE_TYPE (from_se
.expr
),
9448 null_pointer_node
));
9451 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9452 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9453 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9458 vtab
= gfc_find_vtab (&from_expr
->ts
);
9460 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9461 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9462 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9465 gfc_free_expr (to_expr2
);
9466 gfc_init_se (&to_se
, NULL
);
9468 if (from_expr
->ts
.type
== BT_CLASS
)
9470 gfc_free_expr (from_expr2
);
9471 gfc_init_se (&from_se
, NULL
);
9476 /* Deallocate "to". */
9477 if (from_expr
->rank
== 0)
9479 to_se
.want_coarray
= 1;
9480 from_se
.want_coarray
= 1;
9482 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9483 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9485 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9486 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9487 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9491 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9492 NULL_TREE
, NULL_TREE
, true, to_expr
,
9494 gfc_add_expr_to_block (&block
, tmp
);
9496 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9497 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9498 boolean_type_node
, tmp
,
9499 fold_convert (TREE_TYPE (tmp
),
9500 null_pointer_node
));
9501 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9502 3, null_pointer_node
, null_pointer_node
,
9503 build_int_cst (integer_type_node
, 0));
9505 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9506 tmp
, build_empty_stmt (input_location
));
9507 gfc_add_expr_to_block (&block
, tmp
);
9511 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9512 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9513 NULL_TREE
, true, to_expr
, false);
9514 gfc_add_expr_to_block (&block
, tmp
);
9517 /* Move the pointer and update the array descriptor data. */
9518 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9520 /* Set "from" to NULL. */
9521 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9522 gfc_add_modify_loc (input_location
, &block
, tmp
,
9523 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9525 return gfc_finish_block (&block
);
9530 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9534 gcc_assert (code
->resolved_isym
);
9536 switch (code
->resolved_isym
->id
)
9538 case GFC_ISYM_MOVE_ALLOC
:
9539 res
= conv_intrinsic_move_alloc (code
);
9542 case GFC_ISYM_ATOMIC_CAS
:
9543 res
= conv_intrinsic_atomic_cas (code
);
9546 case GFC_ISYM_ATOMIC_ADD
:
9547 case GFC_ISYM_ATOMIC_AND
:
9548 case GFC_ISYM_ATOMIC_DEF
:
9549 case GFC_ISYM_ATOMIC_OR
:
9550 case GFC_ISYM_ATOMIC_XOR
:
9551 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9552 case GFC_ISYM_ATOMIC_FETCH_AND
:
9553 case GFC_ISYM_ATOMIC_FETCH_OR
:
9554 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9555 res
= conv_intrinsic_atomic_op (code
);
9558 case GFC_ISYM_ATOMIC_REF
:
9559 res
= conv_intrinsic_atomic_ref (code
);
9562 case GFC_ISYM_C_F_POINTER
:
9563 case GFC_ISYM_C_F_PROCPOINTER
:
9564 res
= conv_isocbinding_subroutine (code
);
9567 case GFC_ISYM_CAF_SEND
:
9568 res
= conv_caf_send (code
);
9571 case GFC_ISYM_CO_BROADCAST
:
9572 case GFC_ISYM_CO_MIN
:
9573 case GFC_ISYM_CO_MAX
:
9574 case GFC_ISYM_CO_REDUCE
:
9575 case GFC_ISYM_CO_SUM
:
9576 res
= conv_co_collective (code
);
9580 res
= conv_intrinsic_free (code
);
9583 case GFC_ISYM_SYSTEM_CLOCK
:
9584 res
= conv_intrinsic_system_clock (code
);
9595 #include "gt-fortran-trans-intrinsic.h"