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. */
31 #include "fold-const.h"
32 #include "stringpool.h"
33 #include "tree-nested.h"
34 #include "stor-layout.h"
36 #include "diagnostic-core.h" /* For internal_error. */
37 #include "toplev.h" /* For rest_of_decl_compilation. */
40 #include "intrinsic.h"
42 #include "trans-const.h"
43 #include "trans-types.h"
44 #include "trans-array.h"
45 #include "dependency.h" /* For CAF array alias analysis. */
46 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
47 #include "trans-stmt.h"
48 #include "tree-nested.h"
50 /* This maps Fortran intrinsic math functions to external library or GCC
52 typedef struct GTY(()) gfc_intrinsic_map_t
{
53 /* The explicit enum is required to work around inadequacies in the
54 garbage collection/gengtype parsing mechanism. */
57 /* Enum value from the "language-independent", aka C-centric, part
58 of gcc, or END_BUILTINS of no such value set. */
59 enum built_in_function float_built_in
;
60 enum built_in_function double_built_in
;
61 enum built_in_function long_double_built_in
;
62 enum built_in_function complex_float_built_in
;
63 enum built_in_function complex_double_built_in
;
64 enum built_in_function complex_long_double_built_in
;
66 /* True if the naming pattern is to prepend "c" for complex and
67 append "f" for kind=4. False if the naming pattern is to
68 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
71 /* True if a complex version of the function exists. */
72 bool complex_available
;
74 /* True if the function should be marked const. */
77 /* The base library name of this function. */
80 /* Cache decls created for the various operand types. */
92 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
93 defines complex variants of all of the entries in mathbuiltins.def
95 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
96 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
97 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
98 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
99 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
101 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
102 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
103 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
104 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
107 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
108 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
113 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
114 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
115 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
116 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
117 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
119 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
121 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
122 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
123 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
124 #include "mathbuiltins.def"
126 /* Functions in libgfortran. */
127 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
130 LIB_FUNCTION (NONE
, NULL
, false)
135 #undef DEFINE_MATH_BUILTIN
136 #undef DEFINE_MATH_BUILTIN_C
139 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
142 /* Find the correct variant of a given builtin from its argument. */
144 builtin_decl_for_precision (enum built_in_function base_built_in
,
147 enum built_in_function i
= END_BUILTINS
;
149 gfc_intrinsic_map_t
*m
;
150 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
153 if (precision
== TYPE_PRECISION (float_type_node
))
154 i
= m
->float_built_in
;
155 else if (precision
== TYPE_PRECISION (double_type_node
))
156 i
= m
->double_built_in
;
157 else if (precision
== TYPE_PRECISION (long_double_type_node
))
158 i
= m
->long_double_built_in
;
159 else if (precision
== TYPE_PRECISION (float128_type_node
))
161 /* Special treatment, because it is not exactly a built-in, but
162 a library function. */
163 return m
->real16_decl
;
166 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
171 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
174 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
176 if (gfc_real_kinds
[i
].c_float128
)
178 /* For __float128, the story is a bit different, because we return
179 a decl to a library function rather than a built-in. */
180 gfc_intrinsic_map_t
*m
;
181 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
184 return m
->real16_decl
;
187 return builtin_decl_for_precision (double_built_in
,
188 gfc_real_kinds
[i
].mode_precision
);
192 /* Evaluate the arguments to an intrinsic function. The value
193 of NARGS may be less than the actual number of arguments in EXPR
194 to allow optional "KIND" arguments that are not included in the
195 generated code to be ignored. */
198 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
199 tree
*argarray
, int nargs
)
201 gfc_actual_arglist
*actual
;
203 gfc_intrinsic_arg
*formal
;
207 formal
= expr
->value
.function
.isym
->formal
;
208 actual
= expr
->value
.function
.actual
;
210 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
211 actual
= actual
->next
,
212 formal
= formal
? formal
->next
: NULL
)
216 /* Skip omitted optional arguments. */
223 /* Evaluate the parameter. This will substitute scalarized
224 references automatically. */
225 gfc_init_se (&argse
, se
);
227 if (e
->ts
.type
== BT_CHARACTER
)
229 gfc_conv_expr (&argse
, e
);
230 gfc_conv_string_parameter (&argse
);
231 argarray
[curr_arg
++] = argse
.string_length
;
232 gcc_assert (curr_arg
< nargs
);
235 gfc_conv_expr_val (&argse
, e
);
237 /* If an optional argument is itself an optional dummy argument,
238 check its presence and substitute a null if absent. */
239 if (e
->expr_type
== EXPR_VARIABLE
240 && e
->symtree
->n
.sym
->attr
.optional
243 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
245 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
246 gfc_add_block_to_block (&se
->post
, &argse
.post
);
247 argarray
[curr_arg
] = argse
.expr
;
251 /* Count the number of actual arguments to the intrinsic function EXPR
252 including any "hidden" string length arguments. */
255 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
258 gfc_actual_arglist
*actual
;
260 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
265 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
275 /* Conversions between different types are output by the frontend as
276 intrinsic functions. We implement these directly with inline code. */
279 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
285 nargs
= gfc_intrinsic_argument_list_length (expr
);
286 args
= XALLOCAVEC (tree
, nargs
);
288 /* Evaluate all the arguments passed. Whilst we're only interested in the
289 first one here, there are other parts of the front-end that assume this
290 and will trigger an ICE if it's not the case. */
291 type
= gfc_typenode_for_spec (&expr
->ts
);
292 gcc_assert (expr
->value
.function
.actual
->expr
);
293 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
295 /* Conversion between character kinds involves a call to a library
297 if (expr
->ts
.type
== BT_CHARACTER
)
299 tree fndecl
, var
, addr
, tmp
;
301 if (expr
->ts
.kind
== 1
302 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
303 fndecl
= gfor_fndecl_convert_char4_to_char1
;
304 else if (expr
->ts
.kind
== 4
305 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
306 fndecl
= gfor_fndecl_convert_char1_to_char4
;
310 /* Create the variable storing the converted value. */
311 type
= gfc_get_pchar_type (expr
->ts
.kind
);
312 var
= gfc_create_var (type
, "str");
313 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
315 /* Call the library function that will perform the conversion. */
316 gcc_assert (nargs
>= 2);
317 tmp
= build_call_expr_loc (input_location
,
318 fndecl
, 3, addr
, args
[0], args
[1]);
319 gfc_add_expr_to_block (&se
->pre
, tmp
);
321 /* Free the temporary afterwards. */
322 tmp
= gfc_call_free (var
);
323 gfc_add_expr_to_block (&se
->post
, tmp
);
326 se
->string_length
= args
[0];
331 /* Conversion from complex to non-complex involves taking the real
332 component of the value. */
333 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
334 && expr
->ts
.type
!= BT_COMPLEX
)
338 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
339 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
343 se
->expr
= convert (type
, args
[0]);
346 /* This is needed because the gcc backend only implements
347 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
348 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
349 Similarly for CEILING. */
352 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
359 argtype
= TREE_TYPE (arg
);
360 arg
= gfc_evaluate_now (arg
, pblock
);
362 intval
= convert (type
, arg
);
363 intval
= gfc_evaluate_now (intval
, pblock
);
365 tmp
= convert (argtype
, intval
);
366 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
367 boolean_type_node
, tmp
, arg
);
369 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
370 intval
, build_int_cst (type
, 1));
371 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
376 /* Round to nearest integer, away from zero. */
379 build_round_expr (tree arg
, tree restype
)
383 int argprec
, resprec
;
385 argtype
= TREE_TYPE (arg
);
386 argprec
= TYPE_PRECISION (argtype
);
387 resprec
= TYPE_PRECISION (restype
);
389 /* Depending on the type of the result, choose the int intrinsic
390 (iround, available only as a builtin, therefore cannot use it for
391 __float128), long int intrinsic (lround family) or long long
392 intrinsic (llround). We might also need to convert the result
394 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
395 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
396 else if (resprec
<= LONG_TYPE_SIZE
)
397 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
398 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
399 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
403 return fold_convert (restype
, build_call_expr_loc (input_location
,
408 /* Convert a real to an integer using a specific rounding mode.
409 Ideally we would just build the corresponding GENERIC node,
410 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
413 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
414 enum rounding_mode op
)
419 return build_fixbound_expr (pblock
, arg
, type
, 0);
423 return build_fixbound_expr (pblock
, arg
, type
, 1);
427 return build_round_expr (arg
, type
);
431 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
440 /* Round a real value using the specified rounding mode.
441 We use a temporary integer of that same kind size as the result.
442 Values larger than those that can be represented by this kind are
443 unchanged, as they will not be accurate enough to represent the
445 huge = HUGE (KIND (a))
446 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
450 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
462 kind
= expr
->ts
.kind
;
463 nargs
= gfc_intrinsic_argument_list_length (expr
);
466 /* We have builtin functions for some cases. */
470 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
474 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
481 /* Evaluate the argument. */
482 gcc_assert (expr
->value
.function
.actual
->expr
);
483 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
485 /* Use a builtin function if one exists. */
486 if (decl
!= NULL_TREE
)
488 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
492 /* This code is probably redundant, but we'll keep it lying around just
494 type
= gfc_typenode_for_spec (&expr
->ts
);
495 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
497 /* Test if the value is too large to handle sensibly. */
498 gfc_set_model_kind (kind
);
500 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
501 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
502 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
503 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
506 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
507 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
508 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
510 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
512 itype
= gfc_get_int_type (kind
);
514 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
515 tmp
= convert (type
, tmp
);
516 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
522 /* Convert to an integer using the specified rounding mode. */
525 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
531 nargs
= gfc_intrinsic_argument_list_length (expr
);
532 args
= XALLOCAVEC (tree
, nargs
);
534 /* Evaluate the argument, we process all arguments even though we only
535 use the first one for code generation purposes. */
536 type
= gfc_typenode_for_spec (&expr
->ts
);
537 gcc_assert (expr
->value
.function
.actual
->expr
);
538 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
540 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
542 /* Conversion to a different integer kind. */
543 se
->expr
= convert (type
, args
[0]);
547 /* Conversion from complex to non-complex involves taking the real
548 component of the value. */
549 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
550 && expr
->ts
.type
!= BT_COMPLEX
)
554 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
555 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
559 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
564 /* Get the imaginary component of a value. */
567 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
571 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
572 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
573 TREE_TYPE (TREE_TYPE (arg
)), arg
);
577 /* Get the complex conjugate of a value. */
580 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
584 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
585 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
591 define_quad_builtin (const char *name
, tree type
, bool is_const
)
594 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
597 /* Mark the decl as external. */
598 DECL_EXTERNAL (fndecl
) = 1;
599 TREE_PUBLIC (fndecl
) = 1;
601 /* Mark it __attribute__((const)). */
602 TREE_READONLY (fndecl
) = is_const
;
604 rest_of_decl_compilation (fndecl
, 1, 0);
611 /* Initialize function decls for library functions. The external functions
612 are created as required. Builtin functions are added here. */
615 gfc_build_intrinsic_lib_fndecls (void)
617 gfc_intrinsic_map_t
*m
;
618 tree quad_decls
[END_BUILTINS
+ 1];
620 if (gfc_real16_is_float128
)
622 /* If we have soft-float types, we create the decls for their
623 C99-like library functions. For now, we only handle __float128
624 q-suffixed functions. */
626 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
627 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
629 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
631 type
= float128_type_node
;
632 complex_type
= complex_float128_type_node
;
633 /* type (*) (type) */
634 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
636 func_iround
= build_function_type_list (integer_type_node
,
638 /* long (*) (type) */
639 func_lround
= build_function_type_list (long_integer_type_node
,
641 /* long long (*) (type) */
642 func_llround
= build_function_type_list (long_long_integer_type_node
,
644 /* type (*) (type, type) */
645 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
646 /* type (*) (type, &int) */
648 = build_function_type_list (type
,
650 build_pointer_type (integer_type_node
),
652 /* type (*) (type, int) */
653 func_scalbn
= build_function_type_list (type
,
654 type
, integer_type_node
, NULL_TREE
);
655 /* type (*) (complex type) */
656 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
657 /* complex type (*) (complex type, complex type) */
659 = build_function_type_list (complex_type
,
660 complex_type
, complex_type
, NULL_TREE
);
662 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
663 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
664 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
666 /* Only these built-ins are actually needed here. These are used directly
667 from the code, when calling builtin_decl_for_precision() or
668 builtin_decl_for_float_type(). The others are all constructed by
669 gfc_get_intrinsic_lib_fndecl(). */
670 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
671 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
673 #include "mathbuiltins.def"
677 #undef DEFINE_MATH_BUILTIN
678 #undef DEFINE_MATH_BUILTIN_C
682 /* Add GCC builtin functions. */
683 for (m
= gfc_intrinsic_map
;
684 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
686 if (m
->float_built_in
!= END_BUILTINS
)
687 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
688 if (m
->complex_float_built_in
!= END_BUILTINS
)
689 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
690 if (m
->double_built_in
!= END_BUILTINS
)
691 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
692 if (m
->complex_double_built_in
!= END_BUILTINS
)
693 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
695 /* If real(kind=10) exists, it is always long double. */
696 if (m
->long_double_built_in
!= END_BUILTINS
)
697 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
698 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
700 = builtin_decl_explicit (m
->complex_long_double_built_in
);
702 if (!gfc_real16_is_float128
)
704 if (m
->long_double_built_in
!= END_BUILTINS
)
705 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
706 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
708 = builtin_decl_explicit (m
->complex_long_double_built_in
);
710 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
712 /* Quad-precision function calls are constructed when first
713 needed by builtin_decl_for_precision(), except for those
714 that will be used directly (define by OTHER_BUILTIN). */
715 m
->real16_decl
= quad_decls
[m
->double_built_in
];
717 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
719 /* Same thing for the complex ones. */
720 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
726 /* Create a fndecl for a simple intrinsic library function. */
729 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
732 vec
<tree
, va_gc
> *argtypes
;
734 gfc_actual_arglist
*actual
;
737 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
740 if (ts
->type
== BT_REAL
)
745 pdecl
= &m
->real4_decl
;
748 pdecl
= &m
->real8_decl
;
751 pdecl
= &m
->real10_decl
;
754 pdecl
= &m
->real16_decl
;
760 else if (ts
->type
== BT_COMPLEX
)
762 gcc_assert (m
->complex_available
);
767 pdecl
= &m
->complex4_decl
;
770 pdecl
= &m
->complex8_decl
;
773 pdecl
= &m
->complex10_decl
;
776 pdecl
= &m
->complex16_decl
;
790 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
791 if (gfc_real_kinds
[n
].c_float
)
792 snprintf (name
, sizeof (name
), "%s%s%s",
793 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
794 else if (gfc_real_kinds
[n
].c_double
)
795 snprintf (name
, sizeof (name
), "%s%s",
796 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
797 else if (gfc_real_kinds
[n
].c_long_double
)
798 snprintf (name
, sizeof (name
), "%s%s%s",
799 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
800 else if (gfc_real_kinds
[n
].c_float128
)
801 snprintf (name
, sizeof (name
), "%s%s%s",
802 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
808 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
809 ts
->type
== BT_COMPLEX
? 'c' : 'r',
814 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
816 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
817 vec_safe_push (argtypes
, type
);
819 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
820 fndecl
= build_decl (input_location
,
821 FUNCTION_DECL
, get_identifier (name
), type
);
823 /* Mark the decl as external. */
824 DECL_EXTERNAL (fndecl
) = 1;
825 TREE_PUBLIC (fndecl
) = 1;
827 /* Mark it __attribute__((const)), if possible. */
828 TREE_READONLY (fndecl
) = m
->is_constant
;
830 rest_of_decl_compilation (fndecl
, 1, 0);
837 /* Convert an intrinsic function into an external or builtin call. */
840 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
842 gfc_intrinsic_map_t
*m
;
846 unsigned int num_args
;
849 id
= expr
->value
.function
.isym
->id
;
850 /* Find the entry for this function. */
851 for (m
= gfc_intrinsic_map
;
852 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
858 if (m
->id
== GFC_ISYM_NONE
)
860 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
861 expr
->value
.function
.name
, id
);
864 /* Get the decl and generate the call. */
865 num_args
= gfc_intrinsic_argument_list_length (expr
);
866 args
= XALLOCAVEC (tree
, num_args
);
868 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
869 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
870 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
872 fndecl
= build_addr (fndecl
, current_function_decl
);
873 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
877 /* If bounds-checking is enabled, create code to verify at runtime that the
878 string lengths for both expressions are the same (needed for e.g. MERGE).
879 If bounds-checking is not enabled, does nothing. */
882 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
883 tree a
, tree b
, stmtblock_t
* target
)
888 /* If bounds-checking is disabled, do nothing. */
889 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
892 /* Compare the two string lengths. */
893 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
895 /* Output the runtime-check. */
896 name
= gfc_build_cstring_const (intr_name
);
897 name
= gfc_build_addr_expr (pchar_type_node
, name
);
898 gfc_trans_runtime_check (true, false, cond
, target
, where
,
899 "Unequal character lengths (%ld/%ld) in %s",
900 fold_convert (long_integer_type_node
, a
),
901 fold_convert (long_integer_type_node
, b
), name
);
905 /* The EXPONENT(X) intrinsic function is translated into
907 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
908 so that if X is a NaN or infinity, the result is HUGE(0).
912 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
914 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
917 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
918 expr
->value
.function
.actual
->expr
->ts
.kind
);
920 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
921 arg
= gfc_evaluate_now (arg
, &se
->pre
);
923 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
924 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
925 cond
= build_call_expr_loc (input_location
,
926 builtin_decl_explicit (BUILT_IN_ISFINITE
),
929 res
= gfc_create_var (integer_type_node
, NULL
);
930 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
931 gfc_build_addr_expr (NULL_TREE
, res
));
932 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
934 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
937 type
= gfc_typenode_for_spec (&expr
->ts
);
938 se
->expr
= fold_convert (type
, se
->expr
);
942 /* Fill in the following structure
943 struct caf_vector_t {
944 size_t nvec; // size of the vector
951 ptrdiff_t lower_bound;
952 ptrdiff_t upper_bound;
959 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
960 tree lower
, tree upper
, tree stride
,
961 tree vector
, int kind
, tree nvec
)
963 tree field
, type
, tmp
;
965 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
966 type
= TREE_TYPE (desc
);
968 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
969 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
970 desc
, field
, NULL_TREE
);
971 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
974 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
975 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
976 desc
, field
, NULL_TREE
);
977 type
= TREE_TYPE (desc
);
979 /* Access the inner struct. */
980 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
981 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
982 desc
, field
, NULL_TREE
);
983 type
= TREE_TYPE (desc
);
985 if (vector
!= NULL_TREE
)
987 /* Set dim.lower/upper/stride. */
988 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
989 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
990 desc
, field
, NULL_TREE
);
991 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
992 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
993 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
994 desc
, field
, NULL_TREE
);
995 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
999 /* Set vector and kind. */
1000 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1001 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1002 desc
, field
, NULL_TREE
);
1003 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1005 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1006 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1007 desc
, field
, NULL_TREE
);
1008 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1010 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1011 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1012 desc
, field
, NULL_TREE
);
1013 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1019 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1022 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1023 tree lbound
, ubound
, tmp
;
1026 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1028 for (i
= 0; i
< ar
->dimen
; i
++)
1029 switch (ar
->dimen_type
[i
])
1034 gfc_init_se (&argse
, NULL
);
1035 gfc_conv_expr (&argse
, ar
->end
[i
]);
1036 gfc_add_block_to_block (block
, &argse
.pre
);
1037 upper
= gfc_evaluate_now (argse
.expr
, block
);
1040 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1043 gfc_init_se (&argse
, NULL
);
1044 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1045 gfc_add_block_to_block (block
, &argse
.pre
);
1046 stride
= gfc_evaluate_now (argse
.expr
, block
);
1049 stride
= gfc_index_one_node
;
1055 gfc_init_se (&argse
, NULL
);
1056 gfc_conv_expr (&argse
, ar
->start
[i
]);
1057 gfc_add_block_to_block (block
, &argse
.pre
);
1058 lower
= gfc_evaluate_now (argse
.expr
, block
);
1061 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1062 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1065 stride
= gfc_index_one_node
;
1068 nvec
= size_zero_node
;
1069 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1074 gfc_init_se (&argse
, NULL
);
1075 argse
.descriptor_only
= 1;
1076 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1077 gfc_add_block_to_block (block
, &argse
.pre
);
1078 vector
= argse
.expr
;
1079 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1080 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1081 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1082 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1083 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1084 TREE_TYPE (nvec
), nvec
, tmp
);
1085 lower
= gfc_index_zero_node
;
1086 upper
= gfc_index_zero_node
;
1087 stride
= gfc_index_zero_node
;
1088 vector
= gfc_conv_descriptor_data_get (vector
);
1089 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1090 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1095 return gfc_build_addr_expr (NULL_TREE
, var
);
1099 /* Get data from a remote coarray. */
1102 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1103 tree may_require_tmp
)
1105 gfc_expr
*array_expr
;
1107 tree caf_decl
, token
, offset
, image_index
, tmp
;
1108 tree res_var
, dst_var
, type
, kind
, vec
;
1110 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1112 if (se
->ss
&& se
->ss
->info
->useflags
)
1114 /* Access the previously obtained result. */
1115 gfc_conv_tmp_array_ref (se
);
1119 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1120 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1121 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1126 vec
= null_pointer_node
;
1128 gfc_init_se (&argse
, NULL
);
1129 if (array_expr
->rank
== 0)
1131 symbol_attribute attr
;
1133 gfc_clear_attr (&attr
);
1134 gfc_conv_expr (&argse
, array_expr
);
1136 if (lhs
== NULL_TREE
)
1138 gfc_clear_attr (&attr
);
1139 if (array_expr
->ts
.type
== BT_CHARACTER
)
1140 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1141 argse
.string_length
);
1143 res_var
= gfc_create_var (type
, "caf_res");
1144 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1145 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1147 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1148 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1152 /* If has_vector, pass descriptor for whole array and the
1153 vector bounds separately. */
1154 gfc_array_ref
*ar
, ar2
;
1155 bool has_vector
= false;
1157 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1160 ar
= gfc_find_array_ref (expr
);
1162 memset (ar
, '\0', sizeof (*ar
));
1166 gfc_conv_expr_descriptor (&argse
, array_expr
);
1167 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1168 has the wrong type if component references are done. */
1169 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1170 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1175 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1179 if (lhs
== NULL_TREE
)
1181 /* Create temporary. */
1182 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1183 if (se
->loop
->to
[n
] == NULL_TREE
)
1186 gfc_conv_descriptor_lbound_get (argse
.expr
, gfc_rank_cst
[n
]);
1188 gfc_conv_descriptor_ubound_get (argse
.expr
, gfc_rank_cst
[n
]);
1190 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1191 NULL_TREE
, false, true, false,
1192 &array_expr
->where
);
1193 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1194 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1196 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1199 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1200 if (lhs_kind
== NULL_TREE
)
1203 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1204 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1206 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1207 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1208 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1209 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1210 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, argse
.expr
, array_expr
);
1212 /* No overlap possible as we have generated a temporary. */
1213 if (lhs
== NULL_TREE
)
1214 may_require_tmp
= boolean_false_node
;
1216 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 9,
1217 token
, offset
, image_index
, argse
.expr
, vec
,
1218 dst_var
, kind
, lhs_kind
, may_require_tmp
);
1219 gfc_add_expr_to_block (&se
->pre
, tmp
);
1222 gfc_advance_se_ss_chain (se
);
1225 if (array_expr
->ts
.type
== BT_CHARACTER
)
1226 se
->string_length
= argse
.string_length
;
1230 /* Send data to a remove coarray. */
1233 conv_caf_send (gfc_code
*code
) {
1234 gfc_expr
*lhs_expr
, *rhs_expr
;
1235 gfc_se lhs_se
, rhs_se
;
1237 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1238 tree may_require_tmp
;
1239 tree lhs_type
= NULL_TREE
;
1240 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1242 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1244 lhs_expr
= code
->ext
.actual
->expr
;
1245 rhs_expr
= code
->ext
.actual
->next
->expr
;
1246 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1247 ? boolean_false_node
: boolean_true_node
;
1248 gfc_init_block (&block
);
1251 gfc_init_se (&lhs_se
, NULL
);
1252 if (lhs_expr
->rank
== 0)
1254 symbol_attribute attr
;
1255 gfc_clear_attr (&attr
);
1256 gfc_conv_expr (&lhs_se
, lhs_expr
);
1257 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1258 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1259 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1263 /* If has_vector, pass descriptor for whole array and the
1264 vector bounds separately. */
1265 gfc_array_ref
*ar
, ar2
;
1266 bool has_vector
= false;
1268 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1271 ar
= gfc_find_array_ref (lhs_expr
);
1273 memset (ar
, '\0', sizeof (*ar
));
1277 lhs_se
.want_pointer
= 1;
1278 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1279 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1280 has the wrong type if component references are done. */
1281 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1282 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1283 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1284 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1289 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1294 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1295 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1297 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1298 temporary and a loop. */
1299 if (!gfc_is_coindexed (lhs_expr
))
1301 gcc_assert (gfc_is_coindexed (rhs_expr
));
1302 gfc_init_se (&rhs_se
, NULL
);
1303 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1305 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1306 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1307 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1308 return gfc_finish_block (&block
);
1311 /* Obtain token, offset and image index for the LHS. */
1313 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1314 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1315 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1316 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1317 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, lhs_se
.expr
, lhs_expr
);
1320 gfc_init_se (&rhs_se
, NULL
);
1321 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1322 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1323 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1324 if (rhs_expr
->rank
== 0)
1326 symbol_attribute attr
;
1327 gfc_clear_attr (&attr
);
1328 gfc_conv_expr (&rhs_se
, rhs_expr
);
1329 if (!gfc_is_coindexed (rhs_expr
) && rhs_expr
->ts
.type
!= BT_CHARACTER
)
1330 rhs_se
.expr
= fold_convert (lhs_type
, rhs_se
.expr
);
1331 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1332 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1336 /* If has_vector, pass descriptor for whole array and the
1337 vector bounds separately. */
1338 gfc_array_ref
*ar
, ar2
;
1339 bool has_vector
= false;
1342 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
1345 ar
= gfc_find_array_ref (rhs_expr
);
1347 memset (ar
, '\0', sizeof (*ar
));
1351 rhs_se
.want_pointer
= 1;
1352 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1353 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1354 has the wrong type if component references are done. */
1355 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1356 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1357 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1358 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1363 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
1368 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1370 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
1372 if (!gfc_is_coindexed (rhs_expr
))
1373 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 9, token
,
1374 offset
, image_index
, lhs_se
.expr
, vec
,
1375 rhs_se
.expr
, lhs_kind
, rhs_kind
, may_require_tmp
);
1378 tree rhs_token
, rhs_offset
, rhs_image_index
;
1380 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
1381 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1382 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1383 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
1384 gfc_get_caf_token_offset (&rhs_token
, &rhs_offset
, caf_decl
, rhs_se
.expr
,
1386 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
, 13,
1387 token
, offset
, image_index
, lhs_se
.expr
, vec
,
1388 rhs_token
, rhs_offset
, rhs_image_index
,
1389 rhs_se
.expr
, rhs_vec
, lhs_kind
, rhs_kind
,
1392 gfc_add_expr_to_block (&block
, tmp
);
1393 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1394 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1395 return gfc_finish_block (&block
);
1400 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1403 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1404 lbound
, ubound
, extent
, ml
;
1407 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1409 if (expr
->value
.function
.actual
->expr
1410 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1411 distance
= expr
->value
.function
.actual
->expr
;
1413 /* The case -fcoarray=single is handled elsewhere. */
1414 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
1416 /* Argument-free version: THIS_IMAGE(). */
1417 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1421 gfc_init_se (&argse
, NULL
);
1422 gfc_conv_expr_val (&argse
, distance
);
1423 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1424 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1425 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1428 tmp
= integer_zero_node
;
1429 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1431 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1436 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1438 type
= gfc_get_int_type (gfc_default_integer_kind
);
1439 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1440 rank
= expr
->value
.function
.actual
->expr
->rank
;
1442 /* Obtain the descriptor of the COARRAY. */
1443 gfc_init_se (&argse
, NULL
);
1444 argse
.want_coarray
= 1;
1445 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1446 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1447 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1452 /* Create an implicit second parameter from the loop variable. */
1453 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1454 gcc_assert (corank
> 0);
1455 gcc_assert (se
->loop
->dimen
== 1);
1456 gcc_assert (se
->ss
->info
->expr
== expr
);
1458 dim_arg
= se
->loop
->loopvar
[0];
1459 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1460 gfc_array_index_type
, dim_arg
,
1461 build_int_cst (TREE_TYPE (dim_arg
), 1));
1462 gfc_advance_se_ss_chain (se
);
1466 /* Use the passed DIM= argument. */
1467 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1468 gfc_init_se (&argse
, NULL
);
1469 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1470 gfc_array_index_type
);
1471 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1472 dim_arg
= argse
.expr
;
1474 if (INTEGER_CST_P (dim_arg
))
1476 if (wi::ltu_p (dim_arg
, 1)
1477 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1478 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1479 "dimension index", expr
->value
.function
.isym
->name
,
1482 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1484 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1485 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1487 build_int_cst (TREE_TYPE (dim_arg
), 1));
1488 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1489 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1491 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1492 boolean_type_node
, cond
, tmp
);
1493 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1498 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1499 one always has a dim_arg argument.
1501 m = this_image() - 1
1504 sub(1) = m + lcobound(corank)
1508 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1511 extent = gfc_extent(i)
1519 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1520 : m + lcobound(corank)
1523 /* this_image () - 1. */
1524 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1526 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1527 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1530 /* sub(1) = m + lcobound(corank). */
1531 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1532 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1534 lbound
= fold_convert (type
, lbound
);
1535 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1541 m
= gfc_create_var (type
, NULL
);
1542 ml
= gfc_create_var (type
, NULL
);
1543 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1544 min_var
= gfc_create_var (integer_type_node
, NULL
);
1546 /* m = this_image () - 1. */
1547 gfc_add_modify (&se
->pre
, m
, tmp
);
1549 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1550 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1551 fold_convert (integer_type_node
, dim_arg
),
1552 build_int_cst (integer_type_node
, rank
- 1));
1553 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1554 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1556 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1559 tmp
= build_int_cst (integer_type_node
, rank
);
1560 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1562 exit_label
= gfc_build_label_decl (NULL_TREE
);
1563 TREE_USED (exit_label
) = 1;
1566 gfc_init_block (&loop
);
1569 gfc_add_modify (&loop
, ml
, m
);
1572 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1573 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1574 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1575 extent
= fold_convert (type
, extent
);
1578 gfc_add_modify (&loop
, m
,
1579 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1582 /* Exit condition: if (i >= min_var) goto exit_label. */
1583 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1585 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1586 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1587 build_empty_stmt (input_location
));
1588 gfc_add_expr_to_block (&loop
, tmp
);
1590 /* Increment loop variable: i++. */
1591 gfc_add_modify (&loop
, loop_var
,
1592 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1594 build_int_cst (integer_type_node
, 1)));
1596 /* Making the loop... actually loop! */
1597 tmp
= gfc_finish_block (&loop
);
1598 tmp
= build1_v (LOOP_EXPR
, tmp
);
1599 gfc_add_expr_to_block (&se
->pre
, tmp
);
1601 /* The exit label. */
1602 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1603 gfc_add_expr_to_block (&se
->pre
, tmp
);
1605 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1606 : m + lcobound(corank) */
1608 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1609 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1611 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1612 fold_build2_loc (input_location
, PLUS_EXPR
,
1613 gfc_array_index_type
, dim_arg
,
1614 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1615 lbound
= fold_convert (type
, lbound
);
1617 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1618 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1620 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1622 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1623 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1629 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1631 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1633 gfc_se argse
, subse
;
1634 int rank
, corank
, codim
;
1636 type
= gfc_get_int_type (gfc_default_integer_kind
);
1637 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1638 rank
= expr
->value
.function
.actual
->expr
->rank
;
1640 /* Obtain the descriptor of the COARRAY. */
1641 gfc_init_se (&argse
, NULL
);
1642 argse
.want_coarray
= 1;
1643 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1644 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1645 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1648 /* Obtain a handle to the SUB argument. */
1649 gfc_init_se (&subse
, NULL
);
1650 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1651 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1652 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1653 subdesc
= build_fold_indirect_ref_loc (input_location
,
1654 gfc_conv_descriptor_data_get (subse
.expr
));
1656 /* Fortran 2008 does not require that the values remain in the cobounds,
1657 thus we need explicitly check this - and return 0 if they are exceeded. */
1659 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1660 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1661 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1662 fold_convert (gfc_array_index_type
, tmp
),
1665 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1667 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1668 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1669 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1670 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1671 fold_convert (gfc_array_index_type
, tmp
),
1673 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1674 boolean_type_node
, invalid_bound
, cond
);
1675 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1676 fold_convert (gfc_array_index_type
, tmp
),
1678 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1679 boolean_type_node
, invalid_bound
, cond
);
1682 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1684 /* See Fortran 2008, C.10 for the following algorithm. */
1686 /* coindex = sub(corank) - lcobound(n). */
1687 coindex
= fold_convert (gfc_array_index_type
,
1688 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1690 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1691 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1692 fold_convert (gfc_array_index_type
, coindex
),
1695 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1697 tree extent
, ubound
;
1699 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1700 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1701 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1702 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1704 /* coindex *= extent. */
1705 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1706 gfc_array_index_type
, coindex
, extent
);
1708 /* coindex += sub(codim). */
1709 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1710 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1711 gfc_array_index_type
, coindex
,
1712 fold_convert (gfc_array_index_type
, tmp
));
1714 /* coindex -= lbound(codim). */
1715 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1716 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1717 gfc_array_index_type
, coindex
, lbound
);
1720 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1721 fold_convert(type
, coindex
),
1722 build_int_cst (type
, 1));
1724 /* Return 0 if "coindex" exceeds num_images(). */
1726 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
1727 num_images
= build_int_cst (type
, 1);
1730 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1732 build_int_cst (integer_type_node
, -1));
1733 num_images
= fold_convert (type
, tmp
);
1736 tmp
= gfc_create_var (type
, NULL
);
1737 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1739 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1741 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1743 fold_convert (boolean_type_node
, invalid_bound
));
1744 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1745 build_int_cst (type
, 0), tmp
);
1750 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1752 tree tmp
, distance
, failed
;
1755 if (expr
->value
.function
.actual
->expr
)
1757 gfc_init_se (&argse
, NULL
);
1758 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1759 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1760 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1761 distance
= fold_convert (integer_type_node
, argse
.expr
);
1764 distance
= integer_zero_node
;
1766 if (expr
->value
.function
.actual
->next
->expr
)
1768 gfc_init_se (&argse
, NULL
);
1769 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1770 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1771 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1772 failed
= fold_convert (integer_type_node
, argse
.expr
);
1775 failed
= build_int_cst (integer_type_node
, -1);
1777 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1779 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1784 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1788 gfc_init_se (&argse
, NULL
);
1789 argse
.data_not_needed
= 1;
1790 argse
.descriptor_only
= 1;
1792 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1793 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1794 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1796 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1800 /* Evaluate a single upper or lower bound. */
1801 /* TODO: bound intrinsic generates way too much unnecessary code. */
1804 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1806 gfc_actual_arglist
*arg
;
1807 gfc_actual_arglist
*arg2
;
1812 tree cond
, cond1
, cond3
, cond4
, size
;
1816 gfc_array_spec
* as
;
1817 bool assumed_rank_lb_one
;
1819 arg
= expr
->value
.function
.actual
;
1824 /* Create an implicit second parameter from the loop variable. */
1825 gcc_assert (!arg2
->expr
);
1826 gcc_assert (se
->loop
->dimen
== 1);
1827 gcc_assert (se
->ss
->info
->expr
== expr
);
1828 gfc_advance_se_ss_chain (se
);
1829 bound
= se
->loop
->loopvar
[0];
1830 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1831 gfc_array_index_type
, bound
,
1836 /* use the passed argument. */
1837 gcc_assert (arg2
->expr
);
1838 gfc_init_se (&argse
, NULL
);
1839 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1840 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1842 /* Convert from one based to zero based. */
1843 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1844 gfc_array_index_type
, bound
,
1845 gfc_index_one_node
);
1848 /* TODO: don't re-evaluate the descriptor on each iteration. */
1849 /* Get a descriptor for the first parameter. */
1850 gfc_init_se (&argse
, NULL
);
1851 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1852 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1853 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1857 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1859 if (INTEGER_CST_P (bound
))
1861 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1862 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1863 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1864 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1865 "dimension index", upper
? "UBOUND" : "LBOUND",
1869 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1871 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1873 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1874 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1875 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1876 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1877 tmp
= gfc_conv_descriptor_rank (desc
);
1879 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1880 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1881 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1882 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1883 boolean_type_node
, cond
, tmp
);
1884 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1889 /* Take care of the lbound shift for assumed-rank arrays, which are
1890 nonallocatable and nonpointers. Those has a lbound of 1. */
1891 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1892 && ((arg
->expr
->ts
.type
!= BT_CLASS
1893 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1894 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1895 || (arg
->expr
->ts
.type
== BT_CLASS
1896 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1897 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1899 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1900 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1902 /* 13.14.53: Result value for LBOUND
1904 Case (i): For an array section or for an array expression other than a
1905 whole array or array structure component, LBOUND(ARRAY, DIM)
1906 has the value 1. For a whole array or array structure
1907 component, LBOUND(ARRAY, DIM) has the value:
1908 (a) equal to the lower bound for subscript DIM of ARRAY if
1909 dimension DIM of ARRAY does not have extent zero
1910 or if ARRAY is an assumed-size array of rank DIM,
1913 13.14.113: Result value for UBOUND
1915 Case (i): For an array section or for an array expression other than a
1916 whole array or array structure component, UBOUND(ARRAY, DIM)
1917 has the value equal to the number of elements in the given
1918 dimension; otherwise, it has a value equal to the upper bound
1919 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1920 not have size zero and has value zero if dimension DIM has
1923 if (!upper
&& assumed_rank_lb_one
)
1924 se
->expr
= gfc_index_one_node
;
1927 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1929 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1931 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1932 stride
, gfc_index_zero_node
);
1933 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1934 boolean_type_node
, cond3
, cond1
);
1935 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1936 stride
, gfc_index_zero_node
);
1941 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1942 boolean_type_node
, cond3
, cond4
);
1943 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1944 gfc_index_one_node
, lbound
);
1945 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1946 boolean_type_node
, cond4
, cond5
);
1948 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1949 boolean_type_node
, cond
, cond5
);
1951 if (assumed_rank_lb_one
)
1953 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1954 gfc_array_index_type
, ubound
, lbound
);
1955 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1956 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1961 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1962 gfc_array_index_type
, cond
,
1963 tmp
, gfc_index_zero_node
);
1967 if (as
->type
== AS_ASSUMED_SIZE
)
1968 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1969 bound
, build_int_cst (TREE_TYPE (bound
),
1970 arg
->expr
->rank
- 1));
1972 cond
= boolean_false_node
;
1974 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1975 boolean_type_node
, cond3
, cond4
);
1976 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1977 boolean_type_node
, cond
, cond1
);
1979 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1980 gfc_array_index_type
, cond
,
1981 lbound
, gfc_index_one_node
);
1988 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1989 gfc_array_index_type
, ubound
, lbound
);
1990 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1991 gfc_array_index_type
, size
,
1992 gfc_index_one_node
);
1993 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1994 gfc_array_index_type
, se
->expr
,
1995 gfc_index_zero_node
);
1998 se
->expr
= gfc_index_one_node
;
2001 type
= gfc_typenode_for_spec (&expr
->ts
);
2002 se
->expr
= convert (type
, se
->expr
);
2007 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2009 gfc_actual_arglist
*arg
;
2010 gfc_actual_arglist
*arg2
;
2012 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2016 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2017 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2018 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2020 arg
= expr
->value
.function
.actual
;
2023 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2024 corank
= gfc_get_corank (arg
->expr
);
2026 gfc_init_se (&argse
, NULL
);
2027 argse
.want_coarray
= 1;
2029 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2030 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2031 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2036 /* Create an implicit second parameter from the loop variable. */
2037 gcc_assert (!arg2
->expr
);
2038 gcc_assert (corank
> 0);
2039 gcc_assert (se
->loop
->dimen
== 1);
2040 gcc_assert (se
->ss
->info
->expr
== expr
);
2042 bound
= se
->loop
->loopvar
[0];
2043 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2044 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2045 gfc_advance_se_ss_chain (se
);
2049 /* use the passed argument. */
2050 gcc_assert (arg2
->expr
);
2051 gfc_init_se (&argse
, NULL
);
2052 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2053 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2056 if (INTEGER_CST_P (bound
))
2058 if (wi::ltu_p (bound
, 1)
2059 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2060 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2061 "dimension index", expr
->value
.function
.isym
->name
,
2064 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2066 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2067 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2068 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2069 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2070 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2072 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2073 boolean_type_node
, cond
, tmp
);
2074 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2079 /* Subtract 1 to get to zero based and add dimensions. */
2080 switch (arg
->expr
->rank
)
2083 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2084 gfc_array_index_type
, bound
,
2085 gfc_index_one_node
);
2089 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2090 gfc_array_index_type
, bound
,
2091 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2095 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2097 /* Handle UCOBOUND with special handling of the last codimension. */
2098 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2100 /* Last codimension: For -fcoarray=single just return
2101 the lcobound - otherwise add
2102 ceiling (real (num_images ()) / real (size)) - 1
2103 = (num_images () + size - 1) / size - 1
2104 = (num_images - 1) / size(),
2105 where size is the product of the extent of all but the last
2108 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2112 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2113 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2114 2, integer_zero_node
,
2115 build_int_cst (integer_type_node
, -1));
2116 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2117 gfc_array_index_type
,
2118 fold_convert (gfc_array_index_type
, tmp
),
2119 build_int_cst (gfc_array_index_type
, 1));
2120 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2121 gfc_array_index_type
, tmp
,
2122 fold_convert (gfc_array_index_type
, cosize
));
2123 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2124 gfc_array_index_type
, resbound
, tmp
);
2126 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2128 /* ubound = lbound + num_images() - 1. */
2129 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2130 2, integer_zero_node
,
2131 build_int_cst (integer_type_node
, -1));
2132 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2133 gfc_array_index_type
,
2134 fold_convert (gfc_array_index_type
, tmp
),
2135 build_int_cst (gfc_array_index_type
, 1));
2136 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2137 gfc_array_index_type
, resbound
, tmp
);
2142 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2144 build_int_cst (TREE_TYPE (bound
),
2145 arg
->expr
->rank
+ corank
- 1));
2147 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2148 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2149 gfc_array_index_type
, cond
,
2150 resbound
, resbound2
);
2153 se
->expr
= resbound
;
2156 se
->expr
= resbound
;
2158 type
= gfc_typenode_for_spec (&expr
->ts
);
2159 se
->expr
= convert (type
, se
->expr
);
2164 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2166 gfc_actual_arglist
*array_arg
;
2167 gfc_actual_arglist
*dim_arg
;
2171 array_arg
= expr
->value
.function
.actual
;
2172 dim_arg
= array_arg
->next
;
2174 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2176 gfc_init_se (&argse
, NULL
);
2177 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2178 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2179 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2182 gcc_assert (dim_arg
->expr
);
2183 gfc_init_se (&argse
, NULL
);
2184 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2185 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2186 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2187 argse
.expr
, gfc_index_one_node
);
2188 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2193 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2197 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2199 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2203 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2208 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2209 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2218 /* Create a complex value from one or two real components. */
2221 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2227 unsigned int num_args
;
2229 num_args
= gfc_intrinsic_argument_list_length (expr
);
2230 args
= XALLOCAVEC (tree
, num_args
);
2232 type
= gfc_typenode_for_spec (&expr
->ts
);
2233 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2234 real
= convert (TREE_TYPE (type
), args
[0]);
2236 imag
= convert (TREE_TYPE (type
), args
[1]);
2237 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2239 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2240 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2241 imag
= convert (TREE_TYPE (type
), imag
);
2244 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2246 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2250 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2251 MODULO(A, P) = A - FLOOR (A / P) * P
2253 The obvious algorithms above are numerically instable for large
2254 arguments, hence these intrinsics are instead implemented via calls
2255 to the fmod family of functions. It is the responsibility of the
2256 user to ensure that the second argument is non-zero. */
2259 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2269 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2271 switch (expr
->ts
.type
)
2274 /* Integer case is easy, we've got a builtin op. */
2275 type
= TREE_TYPE (args
[0]);
2278 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2281 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2287 /* Check if we have a builtin fmod. */
2288 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2290 /* The builtin should always be available. */
2291 gcc_assert (fmod
!= NULL_TREE
);
2293 tmp
= build_addr (fmod
, current_function_decl
);
2294 se
->expr
= build_call_array_loc (input_location
,
2295 TREE_TYPE (TREE_TYPE (fmod
)),
2300 type
= TREE_TYPE (args
[0]);
2302 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2303 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2306 modulo = arg - floor (arg/arg2) * arg2
2308 In order to calculate the result accurately, we use the fmod
2309 function as follows.
2311 res = fmod (arg, arg2);
2314 if ((arg < 0) xor (arg2 < 0))
2318 res = copysign (0., arg2);
2320 => As two nested ternary exprs:
2322 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2323 : copysign (0., arg2);
2327 zero
= gfc_build_const (type
, integer_zero_node
);
2328 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2329 if (!flag_signed_zeros
)
2331 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2333 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2335 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2336 boolean_type_node
, test
, test2
);
2337 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2339 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2340 boolean_type_node
, test
, test2
);
2341 test
= gfc_evaluate_now (test
, &se
->pre
);
2342 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2343 fold_build2_loc (input_location
,
2345 type
, tmp
, args
[1]),
2350 tree expr1
, copysign
, cscall
;
2351 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2353 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2355 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2357 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2358 boolean_type_node
, test
, test2
);
2359 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2360 fold_build2_loc (input_location
,
2362 type
, tmp
, args
[1]),
2364 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2366 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2368 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2378 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2379 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2380 where the right shifts are logical (i.e. 0's are shifted in).
2381 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2382 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2384 DSHIFTL(I,J,BITSIZE) = J
2386 DSHIFTR(I,J,BITSIZE) = I. */
2389 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2391 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2392 tree args
[3], cond
, tmp
;
2395 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2397 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2398 type
= TREE_TYPE (args
[0]);
2399 bitsize
= TYPE_PRECISION (type
);
2400 utype
= unsigned_type_for (type
);
2401 stype
= TREE_TYPE (args
[2]);
2403 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2404 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2405 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2407 /* The generic case. */
2408 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2409 build_int_cst (stype
, bitsize
), shift
);
2410 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2411 arg1
, dshiftl
? shift
: tmp
);
2413 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2414 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2415 right
= fold_convert (type
, right
);
2417 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2419 /* Special cases. */
2420 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2421 build_int_cst (stype
, 0));
2422 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2423 dshiftl
? arg1
: arg2
, res
);
2425 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2426 build_int_cst (stype
, bitsize
));
2427 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2428 dshiftl
? arg2
: arg1
, res
);
2434 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2437 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2445 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2446 type
= TREE_TYPE (args
[0]);
2448 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2449 val
= gfc_evaluate_now (val
, &se
->pre
);
2451 zero
= gfc_build_const (type
, integer_zero_node
);
2452 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2453 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2457 /* SIGN(A, B) is absolute value of A times sign of B.
2458 The real value versions use library functions to ensure the correct
2459 handling of negative zero. Integer case implemented as:
2460 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2464 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2470 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2471 if (expr
->ts
.type
== BT_REAL
)
2475 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2476 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2478 /* We explicitly have to ignore the minus sign. We do so by using
2479 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2481 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2484 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2485 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2487 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2488 TREE_TYPE (args
[0]), cond
,
2489 build_call_expr_loc (input_location
, abs
, 1,
2491 build_call_expr_loc (input_location
, tmp
, 2,
2495 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2500 /* Having excluded floating point types, we know we are now dealing
2501 with signed integer types. */
2502 type
= TREE_TYPE (args
[0]);
2504 /* Args[0] is used multiple times below. */
2505 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2507 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2508 the signs of A and B are the same, and of all ones if they differ. */
2509 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2510 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2511 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2512 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2514 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2515 is all ones (i.e. -1). */
2516 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2517 fold_build2_loc (input_location
, PLUS_EXPR
,
2518 type
, args
[0], tmp
), tmp
);
2522 /* Test for the presence of an optional argument. */
2525 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2529 arg
= expr
->value
.function
.actual
->expr
;
2530 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2531 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2532 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2536 /* Calculate the double precision product of two single precision values. */
2539 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2544 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2546 /* Convert the args to double precision before multiplying. */
2547 type
= gfc_typenode_for_spec (&expr
->ts
);
2548 args
[0] = convert (type
, args
[0]);
2549 args
[1] = convert (type
, args
[1]);
2550 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2555 /* Return a length one character string containing an ascii character. */
2558 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2563 unsigned int num_args
;
2565 num_args
= gfc_intrinsic_argument_list_length (expr
);
2566 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2568 type
= gfc_get_char_type (expr
->ts
.kind
);
2569 var
= gfc_create_var (type
, "char");
2571 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2572 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2573 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2574 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2579 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2587 unsigned int num_args
;
2589 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2590 args
= XALLOCAVEC (tree
, num_args
);
2592 var
= gfc_create_var (pchar_type_node
, "pstr");
2593 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2595 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2596 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2597 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2599 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2600 tmp
= build_call_array_loc (input_location
,
2601 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2602 fndecl
, num_args
, args
);
2603 gfc_add_expr_to_block (&se
->pre
, tmp
);
2605 /* Free the temporary afterwards, if necessary. */
2606 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2607 len
, build_int_cst (TREE_TYPE (len
), 0));
2608 tmp
= gfc_call_free (var
);
2609 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2610 gfc_add_expr_to_block (&se
->post
, tmp
);
2613 se
->string_length
= len
;
2618 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2626 unsigned int num_args
;
2628 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2629 args
= XALLOCAVEC (tree
, num_args
);
2631 var
= gfc_create_var (pchar_type_node
, "pstr");
2632 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2634 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2635 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2636 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2638 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2639 tmp
= build_call_array_loc (input_location
,
2640 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2641 fndecl
, num_args
, args
);
2642 gfc_add_expr_to_block (&se
->pre
, tmp
);
2644 /* Free the temporary afterwards, if necessary. */
2645 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2646 len
, build_int_cst (TREE_TYPE (len
), 0));
2647 tmp
= gfc_call_free (var
);
2648 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2649 gfc_add_expr_to_block (&se
->post
, tmp
);
2652 se
->string_length
= len
;
2656 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2660 conv_intrinsic_system_clock (gfc_code
*code
)
2663 gfc_se count_se
, count_rate_se
, count_max_se
;
2664 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
2668 gfc_expr
*count
= code
->ext
.actual
->expr
;
2669 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
2670 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
2672 /* Evaluate our arguments. */
2675 gfc_init_se (&count_se
, NULL
);
2676 gfc_conv_expr (&count_se
, count
);
2681 gfc_init_se (&count_rate_se
, NULL
);
2682 gfc_conv_expr (&count_rate_se
, count_rate
);
2687 gfc_init_se (&count_max_se
, NULL
);
2688 gfc_conv_expr (&count_max_se
, count_max
);
2691 /* Find the smallest kind found of the arguments. */
2693 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
2694 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
2696 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
2699 /* Prepare temporary variables. */
2704 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
2705 else if (least
== 4)
2706 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
2707 else if (count
->ts
.kind
== 1)
2708 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
2711 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
2718 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
2719 else if (least
== 4)
2720 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
2722 arg2
= integer_zero_node
;
2728 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
2729 else if (least
== 4)
2730 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
2732 arg3
= integer_zero_node
;
2735 /* Make the function call. */
2736 gfc_init_block (&block
);
2742 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2743 : null_pointer_node
;
2744 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2745 : null_pointer_node
;
2746 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2747 : null_pointer_node
;
2752 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2753 : null_pointer_node
;
2754 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2755 : null_pointer_node
;
2756 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2757 : null_pointer_node
;
2764 tmp
= build_call_expr_loc (input_location
,
2765 gfor_fndecl_system_clock4
, 3,
2766 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2767 : null_pointer_node
,
2768 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2769 : null_pointer_node
,
2770 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2771 : null_pointer_node
);
2772 gfc_add_expr_to_block (&block
, tmp
);
2774 /* Handle kind>=8, 10, or 16 arguments */
2777 tmp
= build_call_expr_loc (input_location
,
2778 gfor_fndecl_system_clock8
, 3,
2779 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2780 : null_pointer_node
,
2781 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2782 : null_pointer_node
,
2783 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2784 : null_pointer_node
);
2785 gfc_add_expr_to_block (&block
, tmp
);
2789 /* And store values back if needed. */
2790 if (arg1
&& arg1
!= count_se
.expr
)
2791 gfc_add_modify (&block
, count_se
.expr
,
2792 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
2793 if (arg2
&& arg2
!= count_rate_se
.expr
)
2794 gfc_add_modify (&block
, count_rate_se
.expr
,
2795 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
2796 if (arg3
&& arg3
!= count_max_se
.expr
)
2797 gfc_add_modify (&block
, count_max_se
.expr
,
2798 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
2800 return gfc_finish_block (&block
);
2804 /* Return a character string containing the tty name. */
2807 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2815 unsigned int num_args
;
2817 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2818 args
= XALLOCAVEC (tree
, num_args
);
2820 var
= gfc_create_var (pchar_type_node
, "pstr");
2821 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2823 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2824 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2825 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2827 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2828 tmp
= build_call_array_loc (input_location
,
2829 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2830 fndecl
, num_args
, args
);
2831 gfc_add_expr_to_block (&se
->pre
, tmp
);
2833 /* Free the temporary afterwards, if necessary. */
2834 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2835 len
, build_int_cst (TREE_TYPE (len
), 0));
2836 tmp
= gfc_call_free (var
);
2837 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2838 gfc_add_expr_to_block (&se
->post
, tmp
);
2841 se
->string_length
= len
;
2845 /* Get the minimum/maximum value of all the parameters.
2846 minmax (a1, a2, a3, ...)
2849 if (a2 .op. mvar || isnan (mvar))
2851 if (a3 .op. mvar || isnan (mvar))
2858 /* TODO: Mismatching types can occur when specific names are used.
2859 These should be handled during resolution. */
2861 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2869 gfc_actual_arglist
*argexpr
;
2870 unsigned int i
, nargs
;
2872 nargs
= gfc_intrinsic_argument_list_length (expr
);
2873 args
= XALLOCAVEC (tree
, nargs
);
2875 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2876 type
= gfc_typenode_for_spec (&expr
->ts
);
2878 argexpr
= expr
->value
.function
.actual
;
2879 if (TREE_TYPE (args
[0]) != type
)
2880 args
[0] = convert (type
, args
[0]);
2881 /* Only evaluate the argument once. */
2882 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2883 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2885 mvar
= gfc_create_var (type
, "M");
2886 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2887 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2893 /* Handle absent optional arguments by ignoring the comparison. */
2894 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2895 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2896 && TREE_CODE (val
) == INDIRECT_REF
)
2897 cond
= fold_build2_loc (input_location
,
2898 NE_EXPR
, boolean_type_node
,
2899 TREE_OPERAND (val
, 0),
2900 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2905 /* Only evaluate the argument once. */
2906 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2907 val
= gfc_evaluate_now (val
, &se
->pre
);
2910 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2912 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2913 convert (type
, val
), mvar
);
2915 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2916 __builtin_isnan might be made dependent on that module being loaded,
2917 to help performance of programs that don't rely on IEEE semantics. */
2918 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2920 isnan
= build_call_expr_loc (input_location
,
2921 builtin_decl_explicit (BUILT_IN_ISNAN
),
2923 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2924 boolean_type_node
, tmp
,
2925 fold_convert (boolean_type_node
, isnan
));
2927 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2928 build_empty_stmt (input_location
));
2930 if (cond
!= NULL_TREE
)
2931 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2932 build_empty_stmt (input_location
));
2934 gfc_add_expr_to_block (&se
->pre
, tmp
);
2935 argexpr
= argexpr
->next
;
2941 /* Generate library calls for MIN and MAX intrinsics for character
2944 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2947 tree var
, len
, fndecl
, tmp
, cond
, function
;
2950 nargs
= gfc_intrinsic_argument_list_length (expr
);
2951 args
= XALLOCAVEC (tree
, nargs
+ 4);
2952 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2954 /* Create the result variables. */
2955 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2956 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2957 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2958 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2959 args
[2] = build_int_cst (integer_type_node
, op
);
2960 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2962 if (expr
->ts
.kind
== 1)
2963 function
= gfor_fndecl_string_minmax
;
2964 else if (expr
->ts
.kind
== 4)
2965 function
= gfor_fndecl_string_minmax_char4
;
2969 /* Make the function call. */
2970 fndecl
= build_addr (function
, current_function_decl
);
2971 tmp
= build_call_array_loc (input_location
,
2972 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2974 gfc_add_expr_to_block (&se
->pre
, tmp
);
2976 /* Free the temporary afterwards, if necessary. */
2977 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2978 len
, build_int_cst (TREE_TYPE (len
), 0));
2979 tmp
= gfc_call_free (var
);
2980 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2981 gfc_add_expr_to_block (&se
->post
, tmp
);
2984 se
->string_length
= len
;
2988 /* Create a symbol node for this intrinsic. The symbol from the frontend
2989 has the generic name. */
2992 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
2996 /* TODO: Add symbols for intrinsic function to the global namespace. */
2997 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2998 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3001 sym
->attr
.external
= 1;
3002 sym
->attr
.function
= 1;
3003 sym
->attr
.always_explicit
= 1;
3004 sym
->attr
.proc
= PROC_INTRINSIC
;
3005 sym
->attr
.flavor
= FL_PROCEDURE
;
3009 sym
->attr
.dimension
= 1;
3010 sym
->as
= gfc_get_array_spec ();
3011 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3012 sym
->as
->rank
= expr
->rank
;
3015 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3016 ignore_optional
? expr
->value
.function
.actual
3022 /* Generate a call to an external intrinsic function. */
3024 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3027 vec
<tree
, va_gc
> *append_args
;
3029 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3032 gcc_assert (expr
->rank
> 0);
3034 gcc_assert (expr
->rank
== 0);
3036 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3038 /* Calls to libgfortran_matmul need to be appended special arguments,
3039 to be able to call the BLAS ?gemm functions if required and possible. */
3041 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3042 && sym
->ts
.type
!= BT_LOGICAL
)
3044 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3046 if (flag_external_blas
3047 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3048 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3052 if (sym
->ts
.type
== BT_REAL
)
3054 if (sym
->ts
.kind
== 4)
3055 gemm_fndecl
= gfor_fndecl_sgemm
;
3057 gemm_fndecl
= gfor_fndecl_dgemm
;
3061 if (sym
->ts
.kind
== 4)
3062 gemm_fndecl
= gfor_fndecl_cgemm
;
3064 gemm_fndecl
= gfor_fndecl_zgemm
;
3067 vec_alloc (append_args
, 3);
3068 append_args
->quick_push (build_int_cst (cint
, 1));
3069 append_args
->quick_push (build_int_cst (cint
,
3070 flag_blas_matmul_limit
));
3071 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3076 vec_alloc (append_args
, 3);
3077 append_args
->quick_push (build_int_cst (cint
, 0));
3078 append_args
->quick_push (build_int_cst (cint
, 0));
3079 append_args
->quick_push (null_pointer_node
);
3083 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3085 gfc_free_symbol (sym
);
3088 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3108 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3117 gfc_actual_arglist
*actual
;
3124 gfc_conv_intrinsic_funcall (se
, expr
);
3128 actual
= expr
->value
.function
.actual
;
3129 type
= gfc_typenode_for_spec (&expr
->ts
);
3130 /* Initialize the result. */
3131 resvar
= gfc_create_var (type
, "test");
3133 tmp
= convert (type
, boolean_true_node
);
3135 tmp
= convert (type
, boolean_false_node
);
3136 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3138 /* Walk the arguments. */
3139 arrayss
= gfc_walk_expr (actual
->expr
);
3140 gcc_assert (arrayss
!= gfc_ss_terminator
);
3142 /* Initialize the scalarizer. */
3143 gfc_init_loopinfo (&loop
);
3144 exit_label
= gfc_build_label_decl (NULL_TREE
);
3145 TREE_USED (exit_label
) = 1;
3146 gfc_add_ss_to_loop (&loop
, arrayss
);
3148 /* Initialize the loop. */
3149 gfc_conv_ss_startstride (&loop
);
3150 gfc_conv_loop_setup (&loop
, &expr
->where
);
3152 gfc_mark_ss_chain_used (arrayss
, 1);
3153 /* Generate the loop body. */
3154 gfc_start_scalarized_body (&loop
, &body
);
3156 /* If the condition matches then set the return value. */
3157 gfc_start_block (&block
);
3159 tmp
= convert (type
, boolean_false_node
);
3161 tmp
= convert (type
, boolean_true_node
);
3162 gfc_add_modify (&block
, resvar
, tmp
);
3164 /* And break out of the loop. */
3165 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3166 gfc_add_expr_to_block (&block
, tmp
);
3168 found
= gfc_finish_block (&block
);
3170 /* Check this element. */
3171 gfc_init_se (&arrayse
, NULL
);
3172 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3173 arrayse
.ss
= arrayss
;
3174 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3176 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3177 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3178 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3179 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3180 gfc_add_expr_to_block (&body
, tmp
);
3181 gfc_add_block_to_block (&body
, &arrayse
.post
);
3183 gfc_trans_scalarizing_loops (&loop
, &body
);
3185 /* Add the exit label. */
3186 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3187 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3189 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3190 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3191 gfc_cleanup_loop (&loop
);
3196 /* COUNT(A) = Number of true elements in A. */
3198 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3205 gfc_actual_arglist
*actual
;
3211 gfc_conv_intrinsic_funcall (se
, expr
);
3215 actual
= expr
->value
.function
.actual
;
3217 type
= gfc_typenode_for_spec (&expr
->ts
);
3218 /* Initialize the result. */
3219 resvar
= gfc_create_var (type
, "count");
3220 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3222 /* Walk the arguments. */
3223 arrayss
= gfc_walk_expr (actual
->expr
);
3224 gcc_assert (arrayss
!= gfc_ss_terminator
);
3226 /* Initialize the scalarizer. */
3227 gfc_init_loopinfo (&loop
);
3228 gfc_add_ss_to_loop (&loop
, arrayss
);
3230 /* Initialize the loop. */
3231 gfc_conv_ss_startstride (&loop
);
3232 gfc_conv_loop_setup (&loop
, &expr
->where
);
3234 gfc_mark_ss_chain_used (arrayss
, 1);
3235 /* Generate the loop body. */
3236 gfc_start_scalarized_body (&loop
, &body
);
3238 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3239 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3240 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3242 gfc_init_se (&arrayse
, NULL
);
3243 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3244 arrayse
.ss
= arrayss
;
3245 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3246 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
3247 build_empty_stmt (input_location
));
3249 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3250 gfc_add_expr_to_block (&body
, tmp
);
3251 gfc_add_block_to_block (&body
, &arrayse
.post
);
3253 gfc_trans_scalarizing_loops (&loop
, &body
);
3255 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3256 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3257 gfc_cleanup_loop (&loop
);
3263 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3264 struct and return the corresponding loopinfo. */
3266 static gfc_loopinfo
*
3267 enter_nested_loop (gfc_se
*se
)
3269 se
->ss
= se
->ss
->nested_ss
;
3270 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
3272 return se
->ss
->loop
;
3276 /* Inline implementation of the sum and product intrinsics. */
3278 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
3282 tree scale
= NULL_TREE
;
3287 gfc_loopinfo loop
, *ploop
;
3288 gfc_actual_arglist
*arg_array
, *arg_mask
;
3289 gfc_ss
*arrayss
= NULL
;
3290 gfc_ss
*maskss
= NULL
;
3294 gfc_expr
*arrayexpr
;
3299 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
3305 type
= gfc_typenode_for_spec (&expr
->ts
);
3306 /* Initialize the result. */
3307 resvar
= gfc_create_var (type
, "val");
3312 scale
= gfc_create_var (type
, "scale");
3313 gfc_add_modify (&se
->pre
, scale
,
3314 gfc_build_const (type
, integer_one_node
));
3315 tmp
= gfc_build_const (type
, integer_zero_node
);
3317 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
3318 tmp
= gfc_build_const (type
, integer_zero_node
);
3319 else if (op
== NE_EXPR
)
3321 tmp
= convert (type
, boolean_false_node
);
3322 else if (op
== BIT_AND_EXPR
)
3323 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
3324 type
, integer_one_node
));
3326 tmp
= gfc_build_const (type
, integer_one_node
);
3328 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3330 arg_array
= expr
->value
.function
.actual
;
3332 arrayexpr
= arg_array
->expr
;
3334 if (op
== NE_EXPR
|| norm2
)
3335 /* PARITY and NORM2. */
3339 arg_mask
= arg_array
->next
->next
;
3340 gcc_assert (arg_mask
!= NULL
);
3341 maskexpr
= arg_mask
->expr
;
3344 if (expr
->rank
== 0)
3346 /* Walk the arguments. */
3347 arrayss
= gfc_walk_expr (arrayexpr
);
3348 gcc_assert (arrayss
!= gfc_ss_terminator
);
3350 if (maskexpr
&& maskexpr
->rank
> 0)
3352 maskss
= gfc_walk_expr (maskexpr
);
3353 gcc_assert (maskss
!= gfc_ss_terminator
);
3358 /* Initialize the scalarizer. */
3359 gfc_init_loopinfo (&loop
);
3360 gfc_add_ss_to_loop (&loop
, arrayss
);
3361 if (maskexpr
&& maskexpr
->rank
> 0)
3362 gfc_add_ss_to_loop (&loop
, maskss
);
3364 /* Initialize the loop. */
3365 gfc_conv_ss_startstride (&loop
);
3366 gfc_conv_loop_setup (&loop
, &expr
->where
);
3368 gfc_mark_ss_chain_used (arrayss
, 1);
3369 if (maskexpr
&& maskexpr
->rank
> 0)
3370 gfc_mark_ss_chain_used (maskss
, 1);
3375 /* All the work has been done in the parent loops. */
3376 ploop
= enter_nested_loop (se
);
3380 /* Generate the loop body. */
3381 gfc_start_scalarized_body (ploop
, &body
);
3383 /* If we have a mask, only add this element if the mask is set. */
3384 if (maskexpr
&& maskexpr
->rank
> 0)
3386 gfc_init_se (&maskse
, parent_se
);
3387 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
3388 if (expr
->rank
== 0)
3390 gfc_conv_expr_val (&maskse
, maskexpr
);
3391 gfc_add_block_to_block (&body
, &maskse
.pre
);
3393 gfc_start_block (&block
);
3396 gfc_init_block (&block
);
3398 /* Do the actual summation/product. */
3399 gfc_init_se (&arrayse
, parent_se
);
3400 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
3401 if (expr
->rank
== 0)
3402 arrayse
.ss
= arrayss
;
3403 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3404 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3408 /* if (x (i) != 0.0)
3414 result = 1.0 + result * val * val;
3420 result += val * val;
3423 tree res1
, res2
, cond
, absX
, val
;
3424 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3426 gfc_init_block (&ifblock1
);
3428 absX
= gfc_create_var (type
, "absX");
3429 gfc_add_modify (&ifblock1
, absX
,
3430 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3432 val
= gfc_create_var (type
, "val");
3433 gfc_add_expr_to_block (&ifblock1
, val
);
3435 gfc_init_block (&ifblock2
);
3436 gfc_add_modify (&ifblock2
, val
,
3437 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3439 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3440 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3441 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3442 gfc_build_const (type
, integer_one_node
));
3443 gfc_add_modify (&ifblock2
, resvar
, res1
);
3444 gfc_add_modify (&ifblock2
, scale
, absX
);
3445 res1
= gfc_finish_block (&ifblock2
);
3447 gfc_init_block (&ifblock3
);
3448 gfc_add_modify (&ifblock3
, val
,
3449 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3451 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3452 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3453 gfc_add_modify (&ifblock3
, resvar
, res2
);
3454 res2
= gfc_finish_block (&ifblock3
);
3456 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3458 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3459 gfc_add_expr_to_block (&ifblock1
, tmp
);
3460 tmp
= gfc_finish_block (&ifblock1
);
3462 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3464 gfc_build_const (type
, integer_zero_node
));
3466 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3467 gfc_add_expr_to_block (&block
, tmp
);
3471 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3472 gfc_add_modify (&block
, resvar
, tmp
);
3475 gfc_add_block_to_block (&block
, &arrayse
.post
);
3477 if (maskexpr
&& maskexpr
->rank
> 0)
3479 /* We enclose the above in if (mask) {...} . */
3481 tmp
= gfc_finish_block (&block
);
3482 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3483 build_empty_stmt (input_location
));
3486 tmp
= gfc_finish_block (&block
);
3487 gfc_add_expr_to_block (&body
, tmp
);
3489 gfc_trans_scalarizing_loops (ploop
, &body
);
3491 /* For a scalar mask, enclose the loop in an if statement. */
3492 if (maskexpr
&& maskexpr
->rank
== 0)
3494 gfc_init_block (&block
);
3495 gfc_add_block_to_block (&block
, &ploop
->pre
);
3496 gfc_add_block_to_block (&block
, &ploop
->post
);
3497 tmp
= gfc_finish_block (&block
);
3501 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3502 build_empty_stmt (input_location
));
3503 gfc_advance_se_ss_chain (se
);
3507 gcc_assert (expr
->rank
== 0);
3508 gfc_init_se (&maskse
, NULL
);
3509 gfc_conv_expr_val (&maskse
, maskexpr
);
3510 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3511 build_empty_stmt (input_location
));
3514 gfc_add_expr_to_block (&block
, tmp
);
3515 gfc_add_block_to_block (&se
->pre
, &block
);
3516 gcc_assert (se
->post
.head
== NULL
);
3520 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3521 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3524 if (expr
->rank
== 0)
3525 gfc_cleanup_loop (ploop
);
3529 /* result = scale * sqrt(result). */
3531 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3532 resvar
= build_call_expr_loc (input_location
,
3534 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3541 /* Inline implementation of the dot_product intrinsic. This function
3542 is based on gfc_conv_intrinsic_arith (the previous function). */
3544 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3552 gfc_actual_arglist
*actual
;
3553 gfc_ss
*arrayss1
, *arrayss2
;
3554 gfc_se arrayse1
, arrayse2
;
3555 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3557 type
= gfc_typenode_for_spec (&expr
->ts
);
3559 /* Initialize the result. */
3560 resvar
= gfc_create_var (type
, "val");
3561 if (expr
->ts
.type
== BT_LOGICAL
)
3562 tmp
= build_int_cst (type
, 0);
3564 tmp
= gfc_build_const (type
, integer_zero_node
);
3566 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3568 /* Walk argument #1. */
3569 actual
= expr
->value
.function
.actual
;
3570 arrayexpr1
= actual
->expr
;
3571 arrayss1
= gfc_walk_expr (arrayexpr1
);
3572 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3574 /* Walk argument #2. */
3575 actual
= actual
->next
;
3576 arrayexpr2
= actual
->expr
;
3577 arrayss2
= gfc_walk_expr (arrayexpr2
);
3578 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3580 /* Initialize the scalarizer. */
3581 gfc_init_loopinfo (&loop
);
3582 gfc_add_ss_to_loop (&loop
, arrayss1
);
3583 gfc_add_ss_to_loop (&loop
, arrayss2
);
3585 /* Initialize the loop. */
3586 gfc_conv_ss_startstride (&loop
);
3587 gfc_conv_loop_setup (&loop
, &expr
->where
);
3589 gfc_mark_ss_chain_used (arrayss1
, 1);
3590 gfc_mark_ss_chain_used (arrayss2
, 1);
3592 /* Generate the loop body. */
3593 gfc_start_scalarized_body (&loop
, &body
);
3594 gfc_init_block (&block
);
3596 /* Make the tree expression for [conjg(]array1[)]. */
3597 gfc_init_se (&arrayse1
, NULL
);
3598 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3599 arrayse1
.ss
= arrayss1
;
3600 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3601 if (expr
->ts
.type
== BT_COMPLEX
)
3602 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3604 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3606 /* Make the tree expression for array2. */
3607 gfc_init_se (&arrayse2
, NULL
);
3608 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3609 arrayse2
.ss
= arrayss2
;
3610 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3611 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3613 /* Do the actual product and sum. */
3614 if (expr
->ts
.type
== BT_LOGICAL
)
3616 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3617 arrayse1
.expr
, arrayse2
.expr
);
3618 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3622 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3624 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3626 gfc_add_modify (&block
, resvar
, tmp
);
3628 /* Finish up the loop block and the loop. */
3629 tmp
= gfc_finish_block (&block
);
3630 gfc_add_expr_to_block (&body
, tmp
);
3632 gfc_trans_scalarizing_loops (&loop
, &body
);
3633 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3634 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3635 gfc_cleanup_loop (&loop
);
3641 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3642 we need to handle. For performance reasons we sometimes create two
3643 loops instead of one, where the second one is much simpler.
3644 Examples for minloc intrinsic:
3645 1) Result is an array, a call is generated
3646 2) Array mask is used and NaNs need to be supported:
3652 if (pos == 0) pos = S + (1 - from);
3653 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3660 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3664 3) NaNs need to be supported, but it is known at compile time or cheaply
3665 at runtime whether array is nonempty or not:
3670 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3673 if (from <= to) pos = 1;
3677 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3681 4) NaNs aren't supported, array mask is used:
3682 limit = infinities_supported ? Infinity : huge (limit);
3686 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3692 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3696 5) Same without array mask:
3697 limit = infinities_supported ? Infinity : huge (limit);
3698 pos = (from <= to) ? 1 : 0;
3701 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3704 For 3) and 5), if mask is scalar, this all goes into a conditional,
3705 setting pos = 0; in the else branch. */
3708 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3712 stmtblock_t ifblock
;
3713 stmtblock_t elseblock
;
3724 gfc_actual_arglist
*actual
;
3729 gfc_expr
*arrayexpr
;
3736 gfc_conv_intrinsic_funcall (se
, expr
);
3740 /* Initialize the result. */
3741 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3742 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3743 type
= gfc_typenode_for_spec (&expr
->ts
);
3745 /* Walk the arguments. */
3746 actual
= expr
->value
.function
.actual
;
3747 arrayexpr
= actual
->expr
;
3748 arrayss
= gfc_walk_expr (arrayexpr
);
3749 gcc_assert (arrayss
!= gfc_ss_terminator
);
3751 actual
= actual
->next
->next
;
3752 gcc_assert (actual
);
3753 maskexpr
= actual
->expr
;
3755 if (maskexpr
&& maskexpr
->rank
!= 0)
3757 maskss
= gfc_walk_expr (maskexpr
);
3758 gcc_assert (maskss
!= gfc_ss_terminator
);
3763 if (gfc_array_size (arrayexpr
, &asize
))
3765 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3767 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3768 boolean_type_node
, nonempty
,
3769 gfc_index_zero_node
);
3774 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3775 switch (arrayexpr
->ts
.type
)
3778 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3782 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3783 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3784 arrayexpr
->ts
.kind
);
3791 /* We start with the most negative possible value for MAXLOC, and the most
3792 positive possible value for MINLOC. The most negative possible value is
3793 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3794 possible value is HUGE in both cases. */
3796 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3797 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
3798 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3799 build_int_cst (TREE_TYPE (tmp
), 1));
3801 gfc_add_modify (&se
->pre
, limit
, tmp
);
3803 /* Initialize the scalarizer. */
3804 gfc_init_loopinfo (&loop
);
3805 gfc_add_ss_to_loop (&loop
, arrayss
);
3807 gfc_add_ss_to_loop (&loop
, maskss
);
3809 /* Initialize the loop. */
3810 gfc_conv_ss_startstride (&loop
);
3812 /* The code generated can have more than one loop in sequence (see the
3813 comment at the function header). This doesn't work well with the
3814 scalarizer, which changes arrays' offset when the scalarization loops
3815 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3816 are currently inlined in the scalar case only (for which loop is of rank
3817 one). As there is no dependency to care about in that case, there is no
3818 temporary, so that we can use the scalarizer temporary code to handle
3819 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3820 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3822 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3823 should eventually go away. We could either create two loops properly,
3824 or find another way to save/restore the array offsets between the two
3825 loops (without conflicting with temporary management), or use a single
3826 loop minmaxloc implementation. See PR 31067. */
3827 loop
.temp_dim
= loop
.dimen
;
3828 gfc_conv_loop_setup (&loop
, &expr
->where
);
3830 gcc_assert (loop
.dimen
== 1);
3831 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3832 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3833 loop
.from
[0], loop
.to
[0]);
3837 /* Initialize the position to zero, following Fortran 2003. We are free
3838 to do this because Fortran 95 allows the result of an entirely false
3839 mask to be processor dependent. If we know at compile time the array
3840 is non-empty and no MASK is used, we can initialize to 1 to simplify
3842 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3843 gfc_add_modify (&loop
.pre
, pos
,
3844 fold_build3_loc (input_location
, COND_EXPR
,
3845 gfc_array_index_type
,
3846 nonempty
, gfc_index_one_node
,
3847 gfc_index_zero_node
));
3850 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3851 lab1
= gfc_build_label_decl (NULL_TREE
);
3852 TREE_USED (lab1
) = 1;
3853 lab2
= gfc_build_label_decl (NULL_TREE
);
3854 TREE_USED (lab2
) = 1;
3857 /* An offset must be added to the loop
3858 counter to obtain the required position. */
3859 gcc_assert (loop
.from
[0]);
3861 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3862 gfc_index_one_node
, loop
.from
[0]);
3863 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3865 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3867 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3868 /* Generate the loop body. */
3869 gfc_start_scalarized_body (&loop
, &body
);
3871 /* If we have a mask, only check this element if the mask is set. */
3874 gfc_init_se (&maskse
, NULL
);
3875 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3877 gfc_conv_expr_val (&maskse
, maskexpr
);
3878 gfc_add_block_to_block (&body
, &maskse
.pre
);
3880 gfc_start_block (&block
);
3883 gfc_init_block (&block
);
3885 /* Compare with the current limit. */
3886 gfc_init_se (&arrayse
, NULL
);
3887 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3888 arrayse
.ss
= arrayss
;
3889 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3890 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3892 /* We do the following if this is a more extreme value. */
3893 gfc_start_block (&ifblock
);
3895 /* Assign the value to the limit... */
3896 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3898 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3900 stmtblock_t ifblock2
;
3903 gfc_start_block (&ifblock2
);
3904 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3905 loop
.loopvar
[0], offset
);
3906 gfc_add_modify (&ifblock2
, pos
, tmp
);
3907 ifbody2
= gfc_finish_block (&ifblock2
);
3908 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3909 gfc_index_zero_node
);
3910 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3911 build_empty_stmt (input_location
));
3912 gfc_add_expr_to_block (&block
, tmp
);
3915 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3916 loop
.loopvar
[0], offset
);
3917 gfc_add_modify (&ifblock
, pos
, tmp
);
3920 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3922 ifbody
= gfc_finish_block (&ifblock
);
3924 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3927 cond
= fold_build2_loc (input_location
,
3928 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3929 boolean_type_node
, arrayse
.expr
, limit
);
3931 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3932 arrayse
.expr
, limit
);
3934 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3935 build_empty_stmt (input_location
));
3937 gfc_add_expr_to_block (&block
, ifbody
);
3941 /* We enclose the above in if (mask) {...}. */
3942 tmp
= gfc_finish_block (&block
);
3944 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3945 build_empty_stmt (input_location
));
3948 tmp
= gfc_finish_block (&block
);
3949 gfc_add_expr_to_block (&body
, tmp
);
3953 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3955 if (HONOR_NANS (DECL_MODE (limit
)))
3957 if (nonempty
!= NULL
)
3959 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3960 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3961 build_empty_stmt (input_location
));
3962 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3966 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3967 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3969 /* If we have a mask, only check this element if the mask is set. */
3972 gfc_init_se (&maskse
, NULL
);
3973 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3975 gfc_conv_expr_val (&maskse
, maskexpr
);
3976 gfc_add_block_to_block (&body
, &maskse
.pre
);
3978 gfc_start_block (&block
);
3981 gfc_init_block (&block
);
3983 /* Compare with the current limit. */
3984 gfc_init_se (&arrayse
, NULL
);
3985 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3986 arrayse
.ss
= arrayss
;
3987 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3988 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3990 /* We do the following if this is a more extreme value. */
3991 gfc_start_block (&ifblock
);
3993 /* Assign the value to the limit... */
3994 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3996 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3997 loop
.loopvar
[0], offset
);
3998 gfc_add_modify (&ifblock
, pos
, tmp
);
4000 ifbody
= gfc_finish_block (&ifblock
);
4002 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4003 arrayse
.expr
, limit
);
4005 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4006 build_empty_stmt (input_location
));
4007 gfc_add_expr_to_block (&block
, tmp
);
4011 /* We enclose the above in if (mask) {...}. */
4012 tmp
= gfc_finish_block (&block
);
4014 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4015 build_empty_stmt (input_location
));
4018 tmp
= gfc_finish_block (&block
);
4019 gfc_add_expr_to_block (&body
, tmp
);
4020 /* Avoid initializing loopvar[0] again, it should be left where
4021 it finished by the first loop. */
4022 loop
.from
[0] = loop
.loopvar
[0];
4025 gfc_trans_scalarizing_loops (&loop
, &body
);
4028 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4030 /* For a scalar mask, enclose the loop in an if statement. */
4031 if (maskexpr
&& maskss
== NULL
)
4033 gfc_init_se (&maskse
, NULL
);
4034 gfc_conv_expr_val (&maskse
, maskexpr
);
4035 gfc_init_block (&block
);
4036 gfc_add_block_to_block (&block
, &loop
.pre
);
4037 gfc_add_block_to_block (&block
, &loop
.post
);
4038 tmp
= gfc_finish_block (&block
);
4040 /* For the else part of the scalar mask, just initialize
4041 the pos variable the same way as above. */
4043 gfc_init_block (&elseblock
);
4044 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4045 elsetmp
= gfc_finish_block (&elseblock
);
4047 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4048 gfc_add_expr_to_block (&block
, tmp
);
4049 gfc_add_block_to_block (&se
->pre
, &block
);
4053 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4054 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4056 gfc_cleanup_loop (&loop
);
4058 se
->expr
= convert (type
, pos
);
4061 /* Emit code for minval or maxval intrinsic. There are many different cases
4062 we need to handle. For performance reasons we sometimes create two
4063 loops instead of one, where the second one is much simpler.
4064 Examples for minval intrinsic:
4065 1) Result is an array, a call is generated
4066 2) Array mask is used and NaNs need to be supported, rank 1:
4071 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4074 limit = nonempty ? NaN : huge (limit);
4076 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4077 3) NaNs need to be supported, but it is known at compile time or cheaply
4078 at runtime whether array is nonempty or not, rank 1:
4081 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4082 limit = (from <= to) ? NaN : huge (limit);
4084 while (S <= to) { limit = min (a[S], limit); S++; }
4085 4) Array mask is used and NaNs need to be supported, rank > 1:
4094 if (fast) limit = min (a[S1][S2], limit);
4097 if (a[S1][S2] <= limit) {
4108 limit = nonempty ? NaN : huge (limit);
4109 5) NaNs need to be supported, but it is known at compile time or cheaply
4110 at runtime whether array is nonempty or not, rank > 1:
4117 if (fast) limit = min (a[S1][S2], limit);
4119 if (a[S1][S2] <= limit) {
4129 limit = (nonempty_array) ? NaN : huge (limit);
4130 6) NaNs aren't supported, but infinities are. Array mask is used:
4135 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4138 limit = nonempty ? limit : huge (limit);
4139 7) Same without array mask:
4142 while (S <= to) { limit = min (a[S], limit); S++; }
4143 limit = (from <= to) ? limit : huge (limit);
4144 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4145 limit = huge (limit);
4147 while (S <= to) { limit = min (a[S], limit); S++); }
4149 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4150 with array mask instead).
4151 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4152 setting limit = huge (limit); in the else branch. */
4155 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4165 tree huge_cst
= NULL
, nan_cst
= NULL
;
4167 stmtblock_t block
, block2
;
4169 gfc_actual_arglist
*actual
;
4174 gfc_expr
*arrayexpr
;
4180 gfc_conv_intrinsic_funcall (se
, expr
);
4184 type
= gfc_typenode_for_spec (&expr
->ts
);
4185 /* Initialize the result. */
4186 limit
= gfc_create_var (type
, "limit");
4187 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4188 switch (expr
->ts
.type
)
4191 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4193 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4195 REAL_VALUE_TYPE real
;
4197 tmp
= build_real (type
, real
);
4201 if (HONOR_NANS (DECL_MODE (limit
)))
4202 nan_cst
= gfc_build_nan (type
, "");
4206 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4213 /* We start with the most negative possible value for MAXVAL, and the most
4214 positive possible value for MINVAL. The most negative possible value is
4215 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4216 possible value is HUGE in both cases. */
4219 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4221 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4222 TREE_TYPE (huge_cst
), huge_cst
);
4225 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4226 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4227 tmp
, build_int_cst (type
, 1));
4229 gfc_add_modify (&se
->pre
, limit
, tmp
);
4231 /* Walk the arguments. */
4232 actual
= expr
->value
.function
.actual
;
4233 arrayexpr
= actual
->expr
;
4234 arrayss
= gfc_walk_expr (arrayexpr
);
4235 gcc_assert (arrayss
!= gfc_ss_terminator
);
4237 actual
= actual
->next
->next
;
4238 gcc_assert (actual
);
4239 maskexpr
= actual
->expr
;
4241 if (maskexpr
&& maskexpr
->rank
!= 0)
4243 maskss
= gfc_walk_expr (maskexpr
);
4244 gcc_assert (maskss
!= gfc_ss_terminator
);
4249 if (gfc_array_size (arrayexpr
, &asize
))
4251 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4253 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4254 boolean_type_node
, nonempty
,
4255 gfc_index_zero_node
);
4260 /* Initialize the scalarizer. */
4261 gfc_init_loopinfo (&loop
);
4262 gfc_add_ss_to_loop (&loop
, arrayss
);
4264 gfc_add_ss_to_loop (&loop
, maskss
);
4266 /* Initialize the loop. */
4267 gfc_conv_ss_startstride (&loop
);
4269 /* The code generated can have more than one loop in sequence (see the
4270 comment at the function header). This doesn't work well with the
4271 scalarizer, which changes arrays' offset when the scalarization loops
4272 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4273 are currently inlined in the scalar case only. As there is no dependency
4274 to care about in that case, there is no temporary, so that we can use the
4275 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4276 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4277 gfc_trans_scalarized_loop_boundary even later to restore offset.
4278 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4279 should eventually go away. We could either create two loops properly,
4280 or find another way to save/restore the array offsets between the two
4281 loops (without conflicting with temporary management), or use a single
4282 loop minmaxval implementation. See PR 31067. */
4283 loop
.temp_dim
= loop
.dimen
;
4284 gfc_conv_loop_setup (&loop
, &expr
->where
);
4286 if (nonempty
== NULL
&& maskss
== NULL
4287 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
4288 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4289 loop
.from
[0], loop
.to
[0]);
4290 nonempty_var
= NULL
;
4291 if (nonempty
== NULL
4292 && (HONOR_INFINITIES (DECL_MODE (limit
))
4293 || HONOR_NANS (DECL_MODE (limit
))))
4295 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
4296 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
4297 nonempty
= nonempty_var
;
4301 if (HONOR_NANS (DECL_MODE (limit
)))
4303 if (loop
.dimen
== 1)
4305 lab
= gfc_build_label_decl (NULL_TREE
);
4306 TREE_USED (lab
) = 1;
4310 fast
= gfc_create_var (boolean_type_node
, "fast");
4311 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
4315 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
4317 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
4318 /* Generate the loop body. */
4319 gfc_start_scalarized_body (&loop
, &body
);
4321 /* If we have a mask, only add this element if the mask is set. */
4324 gfc_init_se (&maskse
, NULL
);
4325 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4327 gfc_conv_expr_val (&maskse
, maskexpr
);
4328 gfc_add_block_to_block (&body
, &maskse
.pre
);
4330 gfc_start_block (&block
);
4333 gfc_init_block (&block
);
4335 /* Compare with the current limit. */
4336 gfc_init_se (&arrayse
, NULL
);
4337 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4338 arrayse
.ss
= arrayss
;
4339 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4340 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4342 gfc_init_block (&block2
);
4345 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
4347 if (HONOR_NANS (DECL_MODE (limit
)))
4349 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4350 boolean_type_node
, arrayse
.expr
, limit
);
4352 ifbody
= build1_v (GOTO_EXPR
, lab
);
4355 stmtblock_t ifblock
;
4357 gfc_init_block (&ifblock
);
4358 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4359 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
4360 ifbody
= gfc_finish_block (&ifblock
);
4362 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4363 build_empty_stmt (input_location
));
4364 gfc_add_expr_to_block (&block2
, tmp
);
4368 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4370 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4372 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4373 arrayse
.expr
, limit
);
4374 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4375 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4376 build_empty_stmt (input_location
));
4377 gfc_add_expr_to_block (&block2
, tmp
);
4381 tmp
= fold_build2_loc (input_location
,
4382 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4383 type
, arrayse
.expr
, limit
);
4384 gfc_add_modify (&block2
, limit
, tmp
);
4390 tree elsebody
= gfc_finish_block (&block2
);
4392 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4394 if (HONOR_NANS (DECL_MODE (limit
))
4395 || 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 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
4401 build_empty_stmt (input_location
));
4405 tmp
= fold_build2_loc (input_location
,
4406 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4407 type
, arrayse
.expr
, limit
);
4408 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4410 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
4411 gfc_add_expr_to_block (&block
, tmp
);
4414 gfc_add_block_to_block (&block
, &block2
);
4416 gfc_add_block_to_block (&block
, &arrayse
.post
);
4418 tmp
= gfc_finish_block (&block
);
4420 /* We enclose the above in if (mask) {...}. */
4421 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4422 build_empty_stmt (input_location
));
4423 gfc_add_expr_to_block (&body
, tmp
);
4427 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4429 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4431 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4432 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4434 /* If we have a mask, only add this element if the mask is set. */
4437 gfc_init_se (&maskse
, NULL
);
4438 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4440 gfc_conv_expr_val (&maskse
, maskexpr
);
4441 gfc_add_block_to_block (&body
, &maskse
.pre
);
4443 gfc_start_block (&block
);
4446 gfc_init_block (&block
);
4448 /* Compare with the current limit. */
4449 gfc_init_se (&arrayse
, NULL
);
4450 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4451 arrayse
.ss
= arrayss
;
4452 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4453 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4455 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4457 if (HONOR_NANS (DECL_MODE (limit
))
4458 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4460 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4461 arrayse
.expr
, limit
);
4462 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4463 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4464 build_empty_stmt (input_location
));
4465 gfc_add_expr_to_block (&block
, tmp
);
4469 tmp
= fold_build2_loc (input_location
,
4470 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4471 type
, arrayse
.expr
, limit
);
4472 gfc_add_modify (&block
, limit
, tmp
);
4475 gfc_add_block_to_block (&block
, &arrayse
.post
);
4477 tmp
= gfc_finish_block (&block
);
4479 /* We enclose the above in if (mask) {...}. */
4480 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4481 build_empty_stmt (input_location
));
4482 gfc_add_expr_to_block (&body
, tmp
);
4483 /* Avoid initializing loopvar[0] again, it should be left where
4484 it finished by the first loop. */
4485 loop
.from
[0] = loop
.loopvar
[0];
4487 gfc_trans_scalarizing_loops (&loop
, &body
);
4491 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4493 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4494 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4496 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4498 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4500 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4502 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4505 /* For a scalar mask, enclose the loop in an if statement. */
4506 if (maskexpr
&& maskss
== NULL
)
4510 gfc_init_se (&maskse
, NULL
);
4511 gfc_conv_expr_val (&maskse
, maskexpr
);
4512 gfc_init_block (&block
);
4513 gfc_add_block_to_block (&block
, &loop
.pre
);
4514 gfc_add_block_to_block (&block
, &loop
.post
);
4515 tmp
= gfc_finish_block (&block
);
4517 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4518 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4520 else_stmt
= build_empty_stmt (input_location
);
4521 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4522 gfc_add_expr_to_block (&block
, tmp
);
4523 gfc_add_block_to_block (&se
->pre
, &block
);
4527 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4528 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4531 gfc_cleanup_loop (&loop
);
4536 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4538 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4544 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4545 type
= TREE_TYPE (args
[0]);
4547 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4548 build_int_cst (type
, 1), args
[1]);
4549 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4550 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4551 build_int_cst (type
, 0));
4552 type
= gfc_typenode_for_spec (&expr
->ts
);
4553 se
->expr
= convert (type
, tmp
);
4557 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4559 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4563 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4565 /* Convert both arguments to the unsigned type of the same size. */
4566 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4567 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4569 /* If they have unequal type size, convert to the larger one. */
4570 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4571 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4572 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4573 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4574 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4575 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4577 /* Now, we compare them. */
4578 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4583 /* Generate code to perform the specified operation. */
4585 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4589 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4590 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4596 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4600 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4601 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4602 TREE_TYPE (arg
), arg
);
4605 /* Set or clear a single bit. */
4607 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4614 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4615 type
= TREE_TYPE (args
[0]);
4617 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4618 build_int_cst (type
, 1), args
[1]);
4624 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4626 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4629 /* Extract a sequence of bits.
4630 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4632 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4639 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4640 type
= TREE_TYPE (args
[0]);
4642 mask
= build_int_cst (type
, -1);
4643 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4644 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4646 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4648 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4652 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4655 tree args
[2], type
, num_bits
, cond
;
4657 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4659 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4660 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4661 type
= TREE_TYPE (args
[0]);
4664 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4666 gcc_assert (right_shift
);
4668 se
->expr
= fold_build2_loc (input_location
,
4669 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4670 TREE_TYPE (args
[0]), args
[0], args
[1]);
4673 se
->expr
= fold_convert (type
, se
->expr
);
4675 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4676 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4678 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4679 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4682 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4683 build_int_cst (type
, 0), se
->expr
);
4686 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4688 : ((shift >= 0) ? i << shift : i >> -shift)
4689 where all shifts are logical shifts. */
4691 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4703 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4705 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4706 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4708 type
= TREE_TYPE (args
[0]);
4709 utype
= unsigned_type_for (type
);
4711 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4714 /* Left shift if positive. */
4715 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4717 /* Right shift if negative.
4718 We convert to an unsigned type because we want a logical shift.
4719 The standard doesn't define the case of shifting negative
4720 numbers, and we try to be compatible with other compilers, most
4721 notably g77, here. */
4722 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4723 utype
, convert (utype
, args
[0]), width
));
4725 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4726 build_int_cst (TREE_TYPE (args
[1]), 0));
4727 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4729 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4730 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4732 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4733 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4735 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4736 build_int_cst (type
, 0), tmp
);
4740 /* Circular shift. AKA rotate or barrel shift. */
4743 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4751 unsigned int num_args
;
4753 num_args
= gfc_intrinsic_argument_list_length (expr
);
4754 args
= XALLOCAVEC (tree
, num_args
);
4756 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4760 /* Use a library function for the 3 parameter version. */
4761 tree int4type
= gfc_get_int_type (4);
4763 type
= TREE_TYPE (args
[0]);
4764 /* We convert the first argument to at least 4 bytes, and
4765 convert back afterwards. This removes the need for library
4766 functions for all argument sizes, and function will be
4767 aligned to at least 32 bits, so there's no loss. */
4768 if (expr
->ts
.kind
< 4)
4769 args
[0] = convert (int4type
, args
[0]);
4771 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4772 need loads of library functions. They cannot have values >
4773 BIT_SIZE (I) so the conversion is safe. */
4774 args
[1] = convert (int4type
, args
[1]);
4775 args
[2] = convert (int4type
, args
[2]);
4777 switch (expr
->ts
.kind
)
4782 tmp
= gfor_fndecl_math_ishftc4
;
4785 tmp
= gfor_fndecl_math_ishftc8
;
4788 tmp
= gfor_fndecl_math_ishftc16
;
4793 se
->expr
= build_call_expr_loc (input_location
,
4794 tmp
, 3, args
[0], args
[1], args
[2]);
4795 /* Convert the result back to the original type, if we extended
4796 the first argument's width above. */
4797 if (expr
->ts
.kind
< 4)
4798 se
->expr
= convert (type
, se
->expr
);
4802 type
= TREE_TYPE (args
[0]);
4804 /* Evaluate arguments only once. */
4805 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4806 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4808 /* Rotate left if positive. */
4809 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4811 /* Rotate right if negative. */
4812 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4814 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4816 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4817 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4819 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4821 /* Do nothing if shift == 0. */
4822 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4824 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4829 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4830 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4832 The conditional expression is necessary because the result of LEADZ(0)
4833 is defined, but the result of __builtin_clz(0) is undefined for most
4836 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4837 difference in bit size between the argument of LEADZ and the C int. */
4840 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4852 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4853 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4855 /* Which variant of __builtin_clz* should we call? */
4856 if (argsize
<= INT_TYPE_SIZE
)
4858 arg_type
= unsigned_type_node
;
4859 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4861 else if (argsize
<= LONG_TYPE_SIZE
)
4863 arg_type
= long_unsigned_type_node
;
4864 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4866 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4868 arg_type
= long_long_unsigned_type_node
;
4869 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4873 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4874 arg_type
= gfc_build_uint_type (argsize
);
4878 /* Convert the actual argument twice: first, to the unsigned type of the
4879 same size; then, to the proper argument type for the built-in
4880 function. But the return type is of the default INTEGER kind. */
4881 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4882 arg
= fold_convert (arg_type
, arg
);
4883 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4884 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4886 /* Compute LEADZ for the case i .ne. 0. */
4889 s
= TYPE_PRECISION (arg_type
) - argsize
;
4890 tmp
= fold_convert (result_type
,
4891 build_call_expr_loc (input_location
, func
,
4893 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4894 tmp
, build_int_cst (result_type
, s
));
4898 /* We end up here if the argument type is larger than 'long long'.
4899 We generate this code:
4901 if (x & (ULL_MAX << ULL_SIZE) != 0)
4902 return clzll ((unsigned long long) (x >> ULLSIZE));
4904 return ULL_SIZE + clzll ((unsigned long long) x);
4905 where ULL_MAX is the largest value that a ULL_MAX can hold
4906 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4907 is the bit-size of the long long type (64 in this example). */
4908 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4910 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4911 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4912 long_long_unsigned_type_node
,
4913 build_int_cst (long_long_unsigned_type_node
,
4916 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4917 fold_convert (arg_type
, ullmax
), ullsize
);
4918 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4920 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4921 cond
, build_int_cst (arg_type
, 0));
4923 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4925 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4926 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4927 tmp1
= fold_convert (result_type
,
4928 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4930 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4931 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4932 tmp2
= fold_convert (result_type
,
4933 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4934 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4937 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4941 /* Build BIT_SIZE. */
4942 bit_size
= build_int_cst (result_type
, argsize
);
4944 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4945 arg
, build_int_cst (arg_type
, 0));
4946 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4951 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4953 The conditional expression is necessary because the result of TRAILZ(0)
4954 is defined, but the result of __builtin_ctz(0) is undefined for most
4958 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4969 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4970 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4972 /* Which variant of __builtin_ctz* should we call? */
4973 if (argsize
<= INT_TYPE_SIZE
)
4975 arg_type
= unsigned_type_node
;
4976 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4978 else if (argsize
<= LONG_TYPE_SIZE
)
4980 arg_type
= long_unsigned_type_node
;
4981 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4983 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4985 arg_type
= long_long_unsigned_type_node
;
4986 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4990 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4991 arg_type
= gfc_build_uint_type (argsize
);
4995 /* Convert the actual argument twice: first, to the unsigned type of the
4996 same size; then, to the proper argument type for the built-in
4997 function. But the return type is of the default INTEGER kind. */
4998 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4999 arg
= fold_convert (arg_type
, arg
);
5000 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5001 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5003 /* Compute TRAILZ for the case i .ne. 0. */
5005 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5009 /* We end up here if the argument type is larger than 'long long'.
5010 We generate this code:
5012 if ((x & ULL_MAX) == 0)
5013 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5015 return ctzll ((unsigned long long) x);
5017 where ULL_MAX is the largest value that a ULL_MAX can hold
5018 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5019 is the bit-size of the long long type (64 in this example). */
5020 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5022 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5023 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5024 long_long_unsigned_type_node
,
5025 build_int_cst (long_long_unsigned_type_node
, 0));
5027 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5028 fold_convert (arg_type
, ullmax
));
5029 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5030 build_int_cst (arg_type
, 0));
5032 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5034 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5035 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5036 tmp1
= fold_convert (result_type
,
5037 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5038 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5041 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5042 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5043 tmp2
= fold_convert (result_type
,
5044 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5046 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5050 /* Build BIT_SIZE. */
5051 bit_size
= build_int_cst (result_type
, argsize
);
5053 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5054 arg
, build_int_cst (arg_type
, 0));
5055 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5059 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5060 for types larger than "long long", we call the long long built-in for
5061 the lower and higher bits and combine the result. */
5064 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5072 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5073 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5074 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5076 /* Which variant of the builtin should we call? */
5077 if (argsize
<= INT_TYPE_SIZE
)
5079 arg_type
= unsigned_type_node
;
5080 func
= builtin_decl_explicit (parity
5082 : BUILT_IN_POPCOUNT
);
5084 else if (argsize
<= LONG_TYPE_SIZE
)
5086 arg_type
= long_unsigned_type_node
;
5087 func
= builtin_decl_explicit (parity
5089 : BUILT_IN_POPCOUNTL
);
5091 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5093 arg_type
= long_long_unsigned_type_node
;
5094 func
= builtin_decl_explicit (parity
5096 : BUILT_IN_POPCOUNTLL
);
5100 /* Our argument type is larger than 'long long', which mean none
5101 of the POPCOUNT builtins covers it. We thus call the 'long long'
5102 variant multiple times, and add the results. */
5103 tree utype
, arg2
, call1
, call2
;
5105 /* For now, we only cover the case where argsize is twice as large
5107 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5109 func
= builtin_decl_explicit (parity
5111 : BUILT_IN_POPCOUNTLL
);
5113 /* Convert it to an integer, and store into a variable. */
5114 utype
= gfc_build_uint_type (argsize
);
5115 arg
= fold_convert (utype
, arg
);
5116 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5118 /* Call the builtin twice. */
5119 call1
= build_call_expr_loc (input_location
, func
, 1,
5120 fold_convert (long_long_unsigned_type_node
,
5123 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5124 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5125 call2
= build_call_expr_loc (input_location
, func
, 1,
5126 fold_convert (long_long_unsigned_type_node
,
5129 /* Combine the results. */
5131 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5134 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5140 /* Convert the actual argument twice: first, to the unsigned type of the
5141 same size; then, to the proper argument type for the built-in
5143 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5144 arg
= fold_convert (arg_type
, arg
);
5146 se
->expr
= fold_convert (result_type
,
5147 build_call_expr_loc (input_location
, func
, 1, arg
));
5151 /* Process an intrinsic with unspecified argument-types that has an optional
5152 argument (which could be of type character), e.g. EOSHIFT. For those, we
5153 need to append the string length of the optional argument if it is not
5154 present and the type is really character.
5155 primary specifies the position (starting at 1) of the non-optional argument
5156 specifying the type and optional gives the position of the optional
5157 argument in the arglist. */
5160 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5161 unsigned primary
, unsigned optional
)
5163 gfc_actual_arglist
* prim_arg
;
5164 gfc_actual_arglist
* opt_arg
;
5166 gfc_actual_arglist
* arg
;
5168 vec
<tree
, va_gc
> *append_args
;
5170 /* Find the two arguments given as position. */
5174 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5178 if (cur_pos
== primary
)
5180 if (cur_pos
== optional
)
5183 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5186 gcc_assert (prim_arg
);
5187 gcc_assert (prim_arg
->expr
);
5188 gcc_assert (opt_arg
);
5190 /* If we do have type CHARACTER and the optional argument is really absent,
5191 append a dummy 0 as string length. */
5193 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5197 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5198 vec_alloc (append_args
, 1);
5199 append_args
->quick_push (dummy
);
5202 /* Build the call itself. */
5203 gcc_assert (!se
->ignore_optional
);
5204 sym
= gfc_get_symbol_for_expr (expr
, false);
5205 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5207 gfc_free_symbol (sym
);
5211 /* The length of a character string. */
5213 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5222 gcc_assert (!se
->ss
);
5224 arg
= expr
->value
.function
.actual
->expr
;
5226 type
= gfc_typenode_for_spec (&expr
->ts
);
5227 switch (arg
->expr_type
)
5230 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5234 /* Obtain the string length from the function used by
5235 trans-array.c(gfc_trans_array_constructor). */
5237 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5241 if (arg
->ref
== NULL
5242 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
5244 /* This doesn't catch all cases.
5245 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5246 and the surrounding thread. */
5247 sym
= arg
->symtree
->n
.sym
;
5248 decl
= gfc_get_symbol_decl (sym
);
5249 if (decl
== current_function_decl
&& sym
->attr
.function
5250 && (sym
->result
== sym
))
5251 decl
= gfc_get_fake_result_decl (sym
, 0);
5253 len
= sym
->ts
.u
.cl
->backend_decl
;
5258 /* Otherwise fall through. */
5261 /* Anybody stupid enough to do this deserves inefficient code. */
5262 gfc_init_se (&argse
, se
);
5264 gfc_conv_expr (&argse
, arg
);
5266 gfc_conv_expr_descriptor (&argse
, arg
);
5267 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5268 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5269 len
= argse
.string_length
;
5272 se
->expr
= convert (type
, len
);
5275 /* The length of a character string not including trailing blanks. */
5277 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
5279 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5280 tree args
[2], type
, fndecl
;
5282 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5283 type
= gfc_typenode_for_spec (&expr
->ts
);
5286 fndecl
= gfor_fndecl_string_len_trim
;
5288 fndecl
= gfor_fndecl_string_len_trim_char4
;
5292 se
->expr
= build_call_expr_loc (input_location
,
5293 fndecl
, 2, args
[0], args
[1]);
5294 se
->expr
= convert (type
, se
->expr
);
5298 /* Returns the starting position of a substring within a string. */
5301 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
5304 tree logical4_type_node
= gfc_get_logical_type (4);
5308 unsigned int num_args
;
5310 args
= XALLOCAVEC (tree
, 5);
5312 /* Get number of arguments; characters count double due to the
5313 string length argument. Kind= is not passed to the library
5314 and thus ignored. */
5315 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
5320 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5321 type
= gfc_typenode_for_spec (&expr
->ts
);
5324 args
[4] = build_int_cst (logical4_type_node
, 0);
5326 args
[4] = convert (logical4_type_node
, args
[4]);
5328 fndecl
= build_addr (function
, current_function_decl
);
5329 se
->expr
= build_call_array_loc (input_location
,
5330 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5332 se
->expr
= convert (type
, se
->expr
);
5336 /* The ascii value for a single character. */
5338 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
5340 tree args
[3], type
, pchartype
;
5343 nargs
= gfc_intrinsic_argument_list_length (expr
);
5344 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
5345 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
5346 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
5347 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
5348 type
= gfc_typenode_for_spec (&expr
->ts
);
5350 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5352 se
->expr
= convert (type
, se
->expr
);
5356 /* Intrinsic ISNAN calls __builtin_isnan. */
5359 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
5363 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5364 se
->expr
= build_call_expr_loc (input_location
,
5365 builtin_decl_explicit (BUILT_IN_ISNAN
),
5367 STRIP_TYPE_NOPS (se
->expr
);
5368 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5372 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5373 their argument against a constant integer value. */
5376 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
5380 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5381 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
5382 gfc_typenode_for_spec (&expr
->ts
),
5383 arg
, build_int_cst (TREE_TYPE (arg
), value
));
5388 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5391 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
5399 unsigned int num_args
;
5401 num_args
= gfc_intrinsic_argument_list_length (expr
);
5402 args
= XALLOCAVEC (tree
, num_args
);
5404 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5405 if (expr
->ts
.type
!= BT_CHARACTER
)
5413 /* We do the same as in the non-character case, but the argument
5414 list is different because of the string length arguments. We
5415 also have to set the string length for the result. */
5422 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5424 se
->string_length
= len
;
5426 type
= TREE_TYPE (tsource
);
5427 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5428 fold_convert (type
, fsource
));
5432 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5435 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5437 tree args
[3], mask
, type
;
5439 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5440 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5442 type
= TREE_TYPE (args
[0]);
5443 gcc_assert (TREE_TYPE (args
[1]) == type
);
5444 gcc_assert (TREE_TYPE (mask
) == type
);
5446 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5447 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5448 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5450 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5455 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5456 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5459 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5461 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5464 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5465 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5467 type
= gfc_get_int_type (expr
->ts
.kind
);
5468 utype
= unsigned_type_for (type
);
5470 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5471 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5473 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5474 build_int_cst (utype
, 0));
5478 /* Left-justified mask. */
5479 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5481 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5482 fold_convert (utype
, res
));
5484 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5485 smaller than type width. */
5486 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5487 build_int_cst (TREE_TYPE (arg
), 0));
5488 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5489 build_int_cst (utype
, 0), res
);
5493 /* Right-justified mask. */
5494 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5495 fold_convert (utype
, arg
));
5496 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5498 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5499 strictly smaller than type width. */
5500 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5502 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5503 cond
, allones
, res
);
5506 se
->expr
= fold_convert (type
, res
);
5510 /* FRACTION (s) is translated into:
5511 isfinite (s) ? frexp (s, &dummy_int) : NaN */
5513 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5515 tree arg
, type
, tmp
, res
, frexp
, cond
;
5517 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5519 type
= gfc_typenode_for_spec (&expr
->ts
);
5520 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5521 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5523 cond
= build_call_expr_loc (input_location
,
5524 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5527 tmp
= gfc_create_var (integer_type_node
, NULL
);
5528 res
= build_call_expr_loc (input_location
, frexp
, 2,
5529 fold_convert (type
, arg
),
5530 gfc_build_addr_expr (NULL_TREE
, tmp
));
5531 res
= fold_convert (type
, res
);
5533 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5534 cond
, res
, gfc_build_nan (type
, ""));
5538 /* NEAREST (s, dir) is translated into
5539 tmp = copysign (HUGE_VAL, dir);
5540 return nextafter (s, tmp);
5543 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5545 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5547 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5548 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5550 type
= gfc_typenode_for_spec (&expr
->ts
);
5551 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5553 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5554 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5555 fold_convert (type
, args
[1]));
5556 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5557 fold_convert (type
, args
[0]), tmp
);
5558 se
->expr
= fold_convert (type
, se
->expr
);
5562 /* SPACING (s) is translated into
5572 e = MAX_EXPR (e, emin);
5573 res = scalbn (1., e);
5577 where prec is the precision of s, gfc_real_kinds[k].digits,
5578 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5579 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5582 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5584 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5585 tree cond
, nan
, tmp
, frexp
, scalbn
;
5589 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5590 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5591 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5592 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5594 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5595 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5597 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5598 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5600 type
= gfc_typenode_for_spec (&expr
->ts
);
5601 e
= gfc_create_var (integer_type_node
, NULL
);
5602 res
= gfc_create_var (type
, NULL
);
5605 /* Build the block for s /= 0. */
5606 gfc_start_block (&block
);
5607 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5608 gfc_build_addr_expr (NULL_TREE
, e
));
5609 gfc_add_expr_to_block (&block
, tmp
);
5611 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5613 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5614 integer_type_node
, tmp
, emin
));
5616 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5617 build_real_from_int_cst (type
, integer_one_node
), e
);
5618 gfc_add_modify (&block
, res
, tmp
);
5620 /* Finish by building the IF statement for value zero. */
5621 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5622 build_real_from_int_cst (type
, integer_zero_node
));
5623 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5624 gfc_finish_block (&block
));
5626 /* And deal with infinities and NaNs. */
5627 cond
= build_call_expr_loc (input_location
,
5628 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5630 nan
= gfc_build_nan (type
, "");
5631 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
5633 gfc_add_expr_to_block (&se
->pre
, tmp
);
5638 /* RRSPACING (s) is translated into
5647 x = scalbn (x, precision - e);
5654 where precision is gfc_real_kinds[k].digits. */
5657 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5659 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5663 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5664 prec
= gfc_real_kinds
[k
].digits
;
5666 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5667 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5668 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5670 type
= gfc_typenode_for_spec (&expr
->ts
);
5671 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5672 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5674 e
= gfc_create_var (integer_type_node
, NULL
);
5675 x
= gfc_create_var (type
, NULL
);
5676 gfc_add_modify (&se
->pre
, x
,
5677 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5680 gfc_start_block (&block
);
5681 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5682 gfc_build_addr_expr (NULL_TREE
, e
));
5683 gfc_add_expr_to_block (&block
, tmp
);
5685 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5686 build_int_cst (integer_type_node
, prec
), e
);
5687 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5688 gfc_add_modify (&block
, x
, tmp
);
5689 stmt
= gfc_finish_block (&block
);
5692 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5693 build_real_from_int_cst (type
, integer_zero_node
));
5694 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5696 /* And deal with infinities and NaNs. */
5697 cond
= build_call_expr_loc (input_location
,
5698 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5700 nan
= gfc_build_nan (type
, "");
5701 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
5703 gfc_add_expr_to_block (&se
->pre
, tmp
);
5704 se
->expr
= fold_convert (type
, x
);
5708 /* SCALE (s, i) is translated into scalbn (s, i). */
5710 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5712 tree args
[2], type
, scalbn
;
5714 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5716 type
= gfc_typenode_for_spec (&expr
->ts
);
5717 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5718 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5719 fold_convert (type
, args
[0]),
5720 fold_convert (integer_type_node
, args
[1]));
5721 se
->expr
= fold_convert (type
, se
->expr
);
5725 /* SET_EXPONENT (s, i) is translated into
5726 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
5728 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5730 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
5732 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5733 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5735 type
= gfc_typenode_for_spec (&expr
->ts
);
5736 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5737 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5739 tmp
= gfc_create_var (integer_type_node
, NULL
);
5740 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5741 fold_convert (type
, args
[0]),
5742 gfc_build_addr_expr (NULL_TREE
, tmp
));
5743 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5744 fold_convert (integer_type_node
, args
[1]));
5745 res
= fold_convert (type
, res
);
5747 /* Call to isfinite */
5748 cond
= build_call_expr_loc (input_location
,
5749 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5751 nan
= gfc_build_nan (type
, "");
5753 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5759 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5761 gfc_actual_arglist
*actual
;
5768 gfc_init_se (&argse
, NULL
);
5769 actual
= expr
->value
.function
.actual
;
5771 if (actual
->expr
->ts
.type
== BT_CLASS
)
5772 gfc_add_class_array_ref (actual
->expr
);
5774 argse
.want_pointer
= 1;
5775 argse
.data_not_needed
= 1;
5776 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5777 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5778 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5779 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5781 /* Build the call to size0. */
5782 fncall0
= build_call_expr_loc (input_location
,
5783 gfor_fndecl_size0
, 1, arg1
);
5785 actual
= actual
->next
;
5789 gfc_init_se (&argse
, NULL
);
5790 gfc_conv_expr_type (&argse
, actual
->expr
,
5791 gfc_array_index_type
);
5792 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5794 /* Unusually, for an intrinsic, size does not exclude
5795 an optional arg2, so we must test for it. */
5796 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5797 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5798 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5801 /* Build the call to size1. */
5802 fncall1
= build_call_expr_loc (input_location
,
5803 gfor_fndecl_size1
, 2,
5806 gfc_init_se (&argse
, NULL
);
5807 argse
.want_pointer
= 1;
5808 argse
.data_not_needed
= 1;
5809 gfc_conv_expr (&argse
, actual
->expr
);
5810 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5811 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5812 argse
.expr
, null_pointer_node
);
5813 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5814 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5815 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5819 se
->expr
= NULL_TREE
;
5820 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5821 gfc_array_index_type
,
5822 argse
.expr
, gfc_index_one_node
);
5825 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5827 argse
.expr
= gfc_index_zero_node
;
5828 se
->expr
= NULL_TREE
;
5833 if (se
->expr
== NULL_TREE
)
5835 tree ubound
, lbound
;
5837 arg1
= build_fold_indirect_ref_loc (input_location
,
5839 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5840 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5841 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5842 gfc_array_index_type
, ubound
, lbound
);
5843 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5844 gfc_array_index_type
,
5845 se
->expr
, gfc_index_one_node
);
5846 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5847 gfc_array_index_type
, se
->expr
,
5848 gfc_index_zero_node
);
5851 type
= gfc_typenode_for_spec (&expr
->ts
);
5852 se
->expr
= convert (type
, se
->expr
);
5856 /* Helper function to compute the size of a character variable,
5857 excluding the terminating null characters. The result has
5858 gfc_array_index_type type. */
5861 size_of_string_in_bytes (int kind
, tree string_length
)
5864 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5866 bytesize
= build_int_cst (gfc_array_index_type
,
5867 gfc_character_kinds
[i
].bit_size
/ 8);
5869 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5871 fold_convert (gfc_array_index_type
, string_length
));
5876 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5887 gfc_init_se (&argse
, NULL
);
5888 arg
= expr
->value
.function
.actual
->expr
;
5890 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
5891 gfc_conv_expr_descriptor (&argse
, arg
);
5893 gfc_conv_expr_reference (&argse
, arg
);
5895 if (arg
->ts
.type
== BT_ASSUMED
)
5897 /* This only works if an array descriptor has been passed; thus, extract
5898 the size from the descriptor. */
5899 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
5900 == TYPE_PRECISION (size_type_node
));
5901 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
5902 tmp
= DECL_LANG_SPECIFIC (tmp
)
5903 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
5904 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
5905 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
5906 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5907 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
5908 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
5909 build_int_cst (TREE_TYPE (tmp
),
5910 GFC_DTYPE_SIZE_SHIFT
));
5911 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
5913 else if (arg
->ts
.type
== BT_CLASS
)
5915 /* For deferred length arrays, conv_expr_descriptor returns an
5916 indirect_ref to the component. */
5918 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
5919 && GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0))))
5920 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
5921 else if (arg
->rank
> 0)
5922 /* The scalarizer added an additional temp. To get the class' vptr
5923 one has to look at the original backend_decl. */
5924 byte_size
= gfc_class_vtab_size_get (
5925 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
5927 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
5931 if (arg
->ts
.type
== BT_CHARACTER
)
5932 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5936 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5939 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5940 byte_size
= fold_convert (gfc_array_index_type
,
5941 size_in_bytes (byte_size
));
5946 se
->expr
= byte_size
;
5949 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5950 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
5952 if (arg
->rank
== -1)
5954 tree cond
, loop_var
, exit_label
;
5957 tmp
= fold_convert (gfc_array_index_type
,
5958 gfc_conv_descriptor_rank (argse
.expr
));
5959 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
5960 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
5961 exit_label
= gfc_build_label_decl (NULL_TREE
);
5968 source_bytes = source_bytes * array.dim[i].extent;
5972 gfc_start_block (&body
);
5973 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5975 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5976 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5977 cond
, tmp
, build_empty_stmt (input_location
));
5978 gfc_add_expr_to_block (&body
, tmp
);
5980 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
5981 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
5982 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
5983 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5984 gfc_array_index_type
, tmp
, source_bytes
);
5985 gfc_add_modify (&body
, source_bytes
, tmp
);
5987 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5988 gfc_array_index_type
, loop_var
,
5989 gfc_index_one_node
);
5990 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
5992 tmp
= gfc_finish_block (&body
);
5994 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
5996 gfc_add_expr_to_block (&argse
.pre
, tmp
);
5998 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5999 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6003 /* Obtain the size of the array in bytes. */
6004 for (n
= 0; n
< arg
->rank
; n
++)
6007 idx
= gfc_rank_cst
[n
];
6008 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6009 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6010 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6011 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6012 gfc_array_index_type
, tmp
, source_bytes
);
6013 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6016 se
->expr
= source_bytes
;
6019 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6024 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6028 tree type
, result_type
, tmp
;
6030 arg
= expr
->value
.function
.actual
->expr
;
6032 gfc_init_se (&argse
, NULL
);
6033 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6037 if (arg
->ts
.type
== BT_CLASS
)
6039 gfc_add_vptr_component (arg
);
6040 gfc_add_size_component (arg
);
6041 gfc_conv_expr (&argse
, arg
);
6042 tmp
= fold_convert (result_type
, argse
.expr
);
6046 gfc_conv_expr_reference (&argse
, arg
);
6047 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6052 argse
.want_pointer
= 0;
6053 gfc_conv_expr_descriptor (&argse
, arg
);
6054 if (arg
->ts
.type
== BT_CLASS
)
6057 tmp
= gfc_class_vtab_size_get (
6058 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6060 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6061 tmp
= fold_convert (result_type
, tmp
);
6064 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6067 /* Obtain the argument's word length. */
6068 if (arg
->ts
.type
== BT_CHARACTER
)
6069 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6071 tmp
= size_in_bytes (type
);
6072 tmp
= fold_convert (result_type
, tmp
);
6075 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6076 build_int_cst (result_type
, BITS_PER_UNIT
));
6077 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6081 /* Intrinsic string comparison functions. */
6084 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6088 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6091 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6092 expr
->value
.function
.actual
->expr
->ts
.kind
,
6094 se
->expr
= fold_build2_loc (input_location
, op
,
6095 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6096 build_int_cst (TREE_TYPE (se
->expr
), 0));
6099 /* Generate a call to the adjustl/adjustr library function. */
6101 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6109 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6112 type
= TREE_TYPE (args
[2]);
6113 var
= gfc_conv_string_tmp (se
, type
, len
);
6116 tmp
= build_call_expr_loc (input_location
,
6117 fndecl
, 3, args
[0], args
[1], args
[2]);
6118 gfc_add_expr_to_block (&se
->pre
, tmp
);
6120 se
->string_length
= len
;
6124 /* Generate code for the TRANSFER intrinsic:
6126 DEST = TRANSFER (SOURCE, MOLD)
6128 typeof<DEST> = typeof<MOLD>
6133 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6135 typeof<DEST> = typeof<MOLD>
6137 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6138 sizeof (DEST(0) * SIZE). */
6140 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6156 gfc_actual_arglist
*arg
;
6158 gfc_array_info
*info
;
6162 gfc_expr
*source_expr
, *mold_expr
;
6166 info
= &se
->ss
->info
->data
.array
;
6168 /* Convert SOURCE. The output from this stage is:-
6169 source_bytes = length of the source in bytes
6170 source = pointer to the source data. */
6171 arg
= expr
->value
.function
.actual
;
6172 source_expr
= arg
->expr
;
6174 /* Ensure double transfer through LOGICAL preserves all
6176 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6177 && arg
->expr
->value
.function
.esym
== NULL
6178 && arg
->expr
->value
.function
.isym
!= NULL
6179 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6180 && arg
->expr
->ts
.type
== BT_LOGICAL
6181 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6182 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6184 gfc_init_se (&argse
, NULL
);
6186 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6188 /* Obtain the pointer to source and the length of source in bytes. */
6189 if (arg
->expr
->rank
== 0)
6191 gfc_conv_expr_reference (&argse
, arg
->expr
);
6192 if (arg
->expr
->ts
.type
== BT_CLASS
)
6193 source
= gfc_class_data_get (argse
.expr
);
6195 source
= argse
.expr
;
6197 /* Obtain the source word length. */
6198 switch (arg
->expr
->ts
.type
)
6201 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6202 argse
.string_length
);
6205 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6208 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6210 tmp
= fold_convert (gfc_array_index_type
,
6211 size_in_bytes (source_type
));
6217 argse
.want_pointer
= 0;
6218 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6219 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6220 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6222 /* Repack the source if not simply contiguous. */
6223 if (!gfc_is_simply_contiguous (arg
->expr
, false))
6225 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6227 if (warn_array_temporaries
)
6228 gfc_warning (OPT_Warray_temporaries
,
6229 "Creating array temporary at %L", &expr
->where
);
6231 source
= build_call_expr_loc (input_location
,
6232 gfor_fndecl_in_pack
, 1, tmp
);
6233 source
= gfc_evaluate_now (source
, &argse
.pre
);
6235 /* Free the temporary. */
6236 gfc_start_block (&block
);
6237 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
6238 gfc_add_expr_to_block (&block
, tmp
);
6239 stmt
= gfc_finish_block (&block
);
6241 /* Clean up if it was repacked. */
6242 gfc_init_block (&block
);
6243 tmp
= gfc_conv_array_data (argse
.expr
);
6244 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6246 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6247 build_empty_stmt (input_location
));
6248 gfc_add_expr_to_block (&block
, tmp
);
6249 gfc_add_block_to_block (&block
, &se
->post
);
6250 gfc_init_block (&se
->post
);
6251 gfc_add_block_to_block (&se
->post
, &block
);
6254 /* Obtain the source word length. */
6255 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6256 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6257 argse
.string_length
);
6259 tmp
= fold_convert (gfc_array_index_type
,
6260 size_in_bytes (source_type
));
6262 /* Obtain the size of the array in bytes. */
6263 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6264 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6267 idx
= gfc_rank_cst
[n
];
6268 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6269 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6270 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6271 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6272 gfc_array_index_type
, upper
, lower
);
6273 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6274 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6275 gfc_array_index_type
, extent
,
6276 gfc_index_one_node
);
6277 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6278 gfc_array_index_type
, tmp
, source_bytes
);
6282 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6283 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6284 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6286 /* Now convert MOLD. The outputs are:
6287 mold_type = the TREE type of MOLD
6288 dest_word_len = destination word length in bytes. */
6290 mold_expr
= arg
->expr
;
6292 gfc_init_se (&argse
, NULL
);
6294 scalar_mold
= arg
->expr
->rank
== 0;
6296 if (arg
->expr
->rank
== 0)
6298 gfc_conv_expr_reference (&argse
, arg
->expr
);
6299 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6304 gfc_init_se (&argse
, NULL
);
6305 argse
.want_pointer
= 0;
6306 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6307 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6310 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6311 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6313 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6315 /* If this TRANSFER is nested in another TRANSFER, use a type
6316 that preserves all bits. */
6317 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6318 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6321 /* Obtain the destination word length. */
6322 switch (arg
->expr
->ts
.type
)
6325 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6326 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6329 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6332 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6335 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6336 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6338 /* Finally convert SIZE, if it is present. */
6340 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6344 gfc_init_se (&argse
, NULL
);
6345 gfc_conv_expr_reference (&argse
, arg
->expr
);
6346 tmp
= convert (gfc_array_index_type
,
6347 build_fold_indirect_ref_loc (input_location
,
6349 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6350 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6355 /* Separate array and scalar results. */
6356 if (scalar_mold
&& tmp
== NULL_TREE
)
6357 goto scalar_transfer
;
6359 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6360 if (tmp
!= NULL_TREE
)
6361 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6362 tmp
, dest_word_len
);
6366 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6367 gfc_add_modify (&se
->pre
, size_words
,
6368 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6369 gfc_array_index_type
,
6370 size_bytes
, dest_word_len
));
6372 /* Evaluate the bounds of the result. If the loop range exists, we have
6373 to check if it is too large. If so, we modify loop->to be consistent
6374 with min(size, size(source)). Otherwise, size is made consistent with
6375 the loop range, so that the right number of bytes is transferred.*/
6376 n
= se
->loop
->order
[0];
6377 if (se
->loop
->to
[n
] != NULL_TREE
)
6379 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6380 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6381 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6382 tmp
, gfc_index_one_node
);
6383 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6385 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6386 gfc_add_modify (&se
->pre
, size_bytes
,
6387 fold_build2_loc (input_location
, MULT_EXPR
,
6388 gfc_array_index_type
,
6389 size_words
, dest_word_len
));
6390 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6391 size_words
, se
->loop
->from
[n
]);
6392 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6393 upper
, gfc_index_one_node
);
6397 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6398 size_words
, gfc_index_one_node
);
6399 se
->loop
->from
[n
] = gfc_index_zero_node
;
6402 se
->loop
->to
[n
] = upper
;
6404 /* Build a destination descriptor, using the pointer, source, as the
6406 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6407 NULL_TREE
, false, true, false, &expr
->where
);
6409 /* Cast the pointer to the result. */
6410 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6411 tmp
= fold_convert (pvoid_type_node
, tmp
);
6413 /* Use memcpy to do the transfer. */
6415 = build_call_expr_loc (input_location
,
6416 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6417 fold_convert (pvoid_type_node
, source
),
6418 fold_convert (size_type_node
,
6419 fold_build2_loc (input_location
,
6421 gfc_array_index_type
,
6424 gfc_add_expr_to_block (&se
->pre
, tmp
);
6426 se
->expr
= info
->descriptor
;
6427 if (expr
->ts
.type
== BT_CHARACTER
)
6428 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6432 /* Deal with scalar results. */
6434 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6435 dest_word_len
, source_bytes
);
6436 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6437 extent
, gfc_index_zero_node
);
6439 if (expr
->ts
.type
== BT_CHARACTER
)
6441 tree direct
, indirect
, free
;
6443 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6444 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6447 /* If source is longer than the destination, use a pointer to
6448 the source directly. */
6449 gfc_init_block (&block
);
6450 gfc_add_modify (&block
, tmpdecl
, ptr
);
6451 direct
= gfc_finish_block (&block
);
6453 /* Otherwise, allocate a string with the length of the destination
6454 and copy the source into it. */
6455 gfc_init_block (&block
);
6456 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6457 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6458 gfc_add_modify (&block
, tmpdecl
,
6459 fold_convert (TREE_TYPE (ptr
), tmp
));
6460 tmp
= build_call_expr_loc (input_location
,
6461 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6462 fold_convert (pvoid_type_node
, tmpdecl
),
6463 fold_convert (pvoid_type_node
, ptr
),
6464 fold_convert (size_type_node
, extent
));
6465 gfc_add_expr_to_block (&block
, tmp
);
6466 indirect
= gfc_finish_block (&block
);
6468 /* Wrap it up with the condition. */
6469 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6470 dest_word_len
, source_bytes
);
6471 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6472 gfc_add_expr_to_block (&se
->pre
, tmp
);
6474 /* Free the temporary string, if necessary. */
6475 free
= gfc_call_free (tmpdecl
);
6476 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6477 dest_word_len
, source_bytes
);
6478 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6479 gfc_add_expr_to_block (&se
->post
, tmp
);
6482 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6486 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6488 ptr
= convert (build_pointer_type (mold_type
), source
);
6490 /* For CLASS results, allocate the needed memory first. */
6491 if (mold_expr
->ts
.type
== BT_CLASS
)
6494 cdata
= gfc_class_data_get (tmpdecl
);
6495 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6496 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6499 /* Use memcpy to do the transfer. */
6500 if (mold_expr
->ts
.type
== BT_CLASS
)
6501 tmp
= gfc_class_data_get (tmpdecl
);
6503 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6505 tmp
= build_call_expr_loc (input_location
,
6506 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6507 fold_convert (pvoid_type_node
, tmp
),
6508 fold_convert (pvoid_type_node
, ptr
),
6509 fold_convert (size_type_node
, extent
));
6510 gfc_add_expr_to_block (&se
->pre
, tmp
);
6512 /* For CLASS results, set the _vptr. */
6513 if (mold_expr
->ts
.type
== BT_CLASS
)
6517 vptr
= gfc_class_vptr_get (tmpdecl
);
6518 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6520 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6521 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6529 /* Generate code for the ALLOCATED intrinsic.
6530 Generate inline code that directly check the address of the argument. */
6533 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6535 gfc_actual_arglist
*arg1
;
6539 gfc_init_se (&arg1se
, NULL
);
6540 arg1
= expr
->value
.function
.actual
;
6542 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6544 /* Make sure that class array expressions have both a _data
6545 component reference and an array reference.... */
6546 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6547 gfc_add_class_array_ref (arg1
->expr
);
6548 /* .... whilst scalars only need the _data component. */
6550 gfc_add_data_component (arg1
->expr
);
6553 if (arg1
->expr
->rank
== 0)
6555 /* Allocatable scalar. */
6556 arg1se
.want_pointer
= 1;
6557 gfc_conv_expr (&arg1se
, arg1
->expr
);
6562 /* Allocatable array. */
6563 arg1se
.descriptor_only
= 1;
6564 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6565 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6568 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6569 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6570 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6574 /* Generate code for the ASSOCIATED intrinsic.
6575 If both POINTER and TARGET are arrays, generate a call to library function
6576 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6577 In other cases, generate inline code that directly compare the address of
6578 POINTER with the address of TARGET. */
6581 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6583 gfc_actual_arglist
*arg1
;
6584 gfc_actual_arglist
*arg2
;
6589 tree nonzero_charlen
;
6590 tree nonzero_arraylen
;
6594 gfc_init_se (&arg1se
, NULL
);
6595 gfc_init_se (&arg2se
, NULL
);
6596 arg1
= expr
->value
.function
.actual
;
6599 /* Check whether the expression is a scalar or not; we cannot use
6600 arg1->expr->rank as it can be nonzero for proc pointers. */
6601 ss
= gfc_walk_expr (arg1
->expr
);
6602 scalar
= ss
== gfc_ss_terminator
;
6604 gfc_free_ss_chain (ss
);
6608 /* No optional target. */
6611 /* A pointer to a scalar. */
6612 arg1se
.want_pointer
= 1;
6613 gfc_conv_expr (&arg1se
, arg1
->expr
);
6614 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6615 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6616 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6618 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6620 tmp2
= gfc_class_data_get (arg1se
.expr
);
6621 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6622 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6629 /* A pointer to an array. */
6630 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6631 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6633 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6634 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6635 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6636 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6641 /* An optional target. */
6642 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6643 gfc_add_data_component (arg2
->expr
);
6645 nonzero_charlen
= NULL_TREE
;
6646 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6647 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6649 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6653 /* A pointer to a scalar. */
6654 arg1se
.want_pointer
= 1;
6655 gfc_conv_expr (&arg1se
, arg1
->expr
);
6656 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6657 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6658 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6660 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6661 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6663 arg2se
.want_pointer
= 1;
6664 gfc_conv_expr (&arg2se
, arg2
->expr
);
6665 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6666 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6667 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6669 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6670 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6671 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6672 arg1se
.expr
, arg2se
.expr
);
6673 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6674 arg1se
.expr
, null_pointer_node
);
6675 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6676 boolean_type_node
, tmp
, tmp2
);
6680 /* An array pointer of zero length is not associated if target is
6682 arg1se
.descriptor_only
= 1;
6683 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6684 if (arg1
->expr
->rank
== -1)
6686 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6687 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6688 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6691 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6692 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6693 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6694 boolean_type_node
, tmp
,
6695 build_int_cst (TREE_TYPE (tmp
), 0));
6697 /* A pointer to an array, call library function _gfor_associated. */
6698 arg1se
.want_pointer
= 1;
6699 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6701 arg2se
.want_pointer
= 1;
6702 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6703 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6704 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6705 se
->expr
= build_call_expr_loc (input_location
,
6706 gfor_fndecl_associated
, 2,
6707 arg1se
.expr
, arg2se
.expr
);
6708 se
->expr
= convert (boolean_type_node
, se
->expr
);
6709 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6710 boolean_type_node
, se
->expr
,
6714 /* If target is present zero character length pointers cannot
6716 if (nonzero_charlen
!= NULL_TREE
)
6717 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6719 se
->expr
, nonzero_charlen
);
6722 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6726 /* Generate code for the SAME_TYPE_AS intrinsic.
6727 Generate inline code that directly checks the vindices. */
6730 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6735 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6737 gfc_init_se (&se1
, NULL
);
6738 gfc_init_se (&se2
, NULL
);
6740 a
= expr
->value
.function
.actual
->expr
;
6741 b
= expr
->value
.function
.actual
->next
->expr
;
6743 if (UNLIMITED_POLY (a
))
6745 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6746 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6747 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6750 if (UNLIMITED_POLY (b
))
6752 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6753 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6754 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6757 if (a
->ts
.type
== BT_CLASS
)
6759 gfc_add_vptr_component (a
);
6760 gfc_add_hash_component (a
);
6762 else if (a
->ts
.type
== BT_DERIVED
)
6763 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6764 a
->ts
.u
.derived
->hash_value
);
6766 if (b
->ts
.type
== BT_CLASS
)
6768 gfc_add_vptr_component (b
);
6769 gfc_add_hash_component (b
);
6771 else if (b
->ts
.type
== BT_DERIVED
)
6772 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6773 b
->ts
.u
.derived
->hash_value
);
6775 gfc_conv_expr (&se1
, a
);
6776 gfc_conv_expr (&se2
, b
);
6778 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6779 boolean_type_node
, se1
.expr
,
6780 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6783 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6784 boolean_type_node
, conda
, tmp
);
6787 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6788 boolean_type_node
, condb
, tmp
);
6790 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6794 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6797 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6801 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6802 se
->expr
= build_call_expr_loc (input_location
,
6803 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6804 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6808 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6811 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6815 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6817 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6818 type
= gfc_get_int_type (4);
6819 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6821 /* Convert it to the required type. */
6822 type
= gfc_typenode_for_spec (&expr
->ts
);
6823 se
->expr
= build_call_expr_loc (input_location
,
6824 gfor_fndecl_si_kind
, 1, arg
);
6825 se
->expr
= fold_convert (type
, se
->expr
);
6829 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6832 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6834 gfc_actual_arglist
*actual
;
6837 vec
<tree
, va_gc
> *args
= NULL
;
6839 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6841 gfc_init_se (&argse
, se
);
6843 /* Pass a NULL pointer for an absent arg. */
6844 if (actual
->expr
== NULL
)
6845 argse
.expr
= null_pointer_node
;
6851 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6853 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6854 ts
.type
= BT_INTEGER
;
6855 ts
.kind
= gfc_c_int_kind
;
6856 gfc_convert_type (actual
->expr
, &ts
, 2);
6858 gfc_conv_expr_reference (&argse
, actual
->expr
);
6861 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6862 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6863 vec_safe_push (args
, argse
.expr
);
6866 /* Convert it to the required type. */
6867 type
= gfc_typenode_for_spec (&expr
->ts
);
6868 se
->expr
= build_call_expr_loc_vec (input_location
,
6869 gfor_fndecl_sr_kind
, args
);
6870 se
->expr
= fold_convert (type
, se
->expr
);
6874 /* Generate code for TRIM (A) intrinsic function. */
6877 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6887 unsigned int num_args
;
6889 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6890 args
= XALLOCAVEC (tree
, num_args
);
6892 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6893 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6894 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6896 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6897 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6900 if (expr
->ts
.kind
== 1)
6901 function
= gfor_fndecl_string_trim
;
6902 else if (expr
->ts
.kind
== 4)
6903 function
= gfor_fndecl_string_trim_char4
;
6907 fndecl
= build_addr (function
, current_function_decl
);
6908 tmp
= build_call_array_loc (input_location
,
6909 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6911 gfc_add_expr_to_block (&se
->pre
, tmp
);
6913 /* Free the temporary afterwards, if necessary. */
6914 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6915 len
, build_int_cst (TREE_TYPE (len
), 0));
6916 tmp
= gfc_call_free (var
);
6917 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6918 gfc_add_expr_to_block (&se
->post
, tmp
);
6921 se
->string_length
= len
;
6925 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6928 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6930 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6931 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6933 stmtblock_t block
, body
;
6936 /* We store in charsize the size of a character. */
6937 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6938 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6940 /* Get the arguments. */
6941 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6942 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6944 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6945 ncopies_type
= TREE_TYPE (ncopies
);
6947 /* Check that NCOPIES is not negative. */
6948 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6949 build_int_cst (ncopies_type
, 0));
6950 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6951 "Argument NCOPIES of REPEAT intrinsic is negative "
6952 "(its value is %ld)",
6953 fold_convert (long_integer_type_node
, ncopies
));
6955 /* If the source length is zero, any non negative value of NCOPIES
6956 is valid, and nothing happens. */
6957 n
= gfc_create_var (ncopies_type
, "ncopies");
6958 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6959 build_int_cst (size_type_node
, 0));
6960 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6961 build_int_cst (ncopies_type
, 0), ncopies
);
6962 gfc_add_modify (&se
->pre
, n
, tmp
);
6965 /* Check that ncopies is not too large: ncopies should be less than
6966 (or equal to) MAX / slen, where MAX is the maximal integer of
6967 the gfc_charlen_type_node type. If slen == 0, we need a special
6968 case to avoid the division by zero. */
6969 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6970 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6971 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6972 fold_convert (size_type_node
, max
), slen
);
6973 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6974 ? size_type_node
: ncopies_type
;
6975 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6976 fold_convert (largest
, ncopies
),
6977 fold_convert (largest
, max
));
6978 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6979 build_int_cst (size_type_node
, 0));
6980 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6981 boolean_false_node
, cond
);
6982 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6983 "Argument NCOPIES of REPEAT intrinsic is too large");
6985 /* Compute the destination length. */
6986 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6987 fold_convert (gfc_charlen_type_node
, slen
),
6988 fold_convert (gfc_charlen_type_node
, ncopies
));
6989 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6990 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6992 /* Generate the code to do the repeat operation:
6993 for (i = 0; i < ncopies; i++)
6994 memmove (dest + (i * slen * size), src, slen*size); */
6995 gfc_start_block (&block
);
6996 count
= gfc_create_var (ncopies_type
, "count");
6997 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6998 exit_label
= gfc_build_label_decl (NULL_TREE
);
7000 /* Start the loop body. */
7001 gfc_start_block (&body
);
7003 /* Exit the loop if count >= ncopies. */
7004 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7006 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7007 TREE_USED (exit_label
) = 1;
7008 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7009 build_empty_stmt (input_location
));
7010 gfc_add_expr_to_block (&body
, tmp
);
7012 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7013 tmp
= 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
, count
));
7016 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7017 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7018 tmp
= fold_build_pointer_plus_loc (input_location
,
7019 fold_convert (pvoid_type_node
, dest
), tmp
);
7020 tmp
= build_call_expr_loc (input_location
,
7021 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7023 fold_build2_loc (input_location
, MULT_EXPR
,
7024 size_type_node
, slen
,
7025 fold_convert (size_type_node
,
7027 gfc_add_expr_to_block (&body
, tmp
);
7029 /* Increment count. */
7030 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7031 count
, build_int_cst (TREE_TYPE (count
), 1));
7032 gfc_add_modify (&body
, count
, tmp
);
7034 /* Build the loop. */
7035 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7036 gfc_add_expr_to_block (&block
, tmp
);
7038 /* Add the exit label. */
7039 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7040 gfc_add_expr_to_block (&block
, tmp
);
7042 /* Finish the block. */
7043 tmp
= gfc_finish_block (&block
);
7044 gfc_add_expr_to_block (&se
->pre
, tmp
);
7046 /* Set the result value. */
7048 se
->string_length
= dlen
;
7052 /* Generate code for the IARGC intrinsic. */
7055 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7061 /* Call the library function. This always returns an INTEGER(4). */
7062 fndecl
= gfor_fndecl_iargc
;
7063 tmp
= build_call_expr_loc (input_location
,
7066 /* Convert it to the required type. */
7067 type
= gfc_typenode_for_spec (&expr
->ts
);
7068 tmp
= fold_convert (type
, tmp
);
7074 /* The loc intrinsic returns the address of its argument as
7075 gfc_index_integer_kind integer. */
7078 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7083 gcc_assert (!se
->ss
);
7085 arg_expr
= expr
->value
.function
.actual
->expr
;
7086 if (arg_expr
->rank
== 0)
7088 if (arg_expr
->ts
.type
== BT_CLASS
)
7089 gfc_add_component_ref (arg_expr
, "_data");
7090 gfc_conv_expr_reference (se
, arg_expr
);
7093 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7094 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7096 /* Create a temporary variable for loc return value. Without this,
7097 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7098 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7099 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7100 se
->expr
= temp_var
;
7104 /* The following routine generates code for the intrinsic
7105 functions from the ISO_C_BINDING module:
7111 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7113 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7115 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7117 if (arg
->expr
->rank
== 0)
7118 gfc_conv_expr_reference (se
, arg
->expr
);
7119 else if (gfc_is_simply_contiguous (arg
->expr
, false))
7120 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7123 gfc_conv_expr_descriptor (se
, arg
->expr
);
7124 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7127 /* TODO -- the following two lines shouldn't be necessary, but if
7128 they're removed, a bug is exposed later in the code path.
7129 This workaround was thus introduced, but will have to be
7130 removed; please see PR 35150 for details about the issue. */
7131 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7132 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7134 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7135 gfc_conv_expr_reference (se
, arg
->expr
);
7136 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7141 /* Build the addr_expr for the first argument. The argument is
7142 already an *address* so we don't need to set want_pointer in
7144 gfc_init_se (&arg1se
, NULL
);
7145 gfc_conv_expr (&arg1se
, arg
->expr
);
7146 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7147 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7149 /* See if we were given two arguments. */
7150 if (arg
->next
->expr
== NULL
)
7151 /* Only given one arg so generate a null and do a
7152 not-equal comparison against the first arg. */
7153 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7155 fold_convert (TREE_TYPE (arg1se
.expr
),
7156 null_pointer_node
));
7162 /* Given two arguments so build the arg2se from second arg. */
7163 gfc_init_se (&arg2se
, NULL
);
7164 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7165 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7166 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7168 /* Generate test to compare that the two args are equal. */
7169 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7170 arg1se
.expr
, arg2se
.expr
);
7171 /* Generate test to ensure that the first arg is not null. */
7172 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7174 arg1se
.expr
, null_pointer_node
);
7176 /* Finally, the generated test must check that both arg1 is not
7177 NULL and that it is equal to the second arg. */
7178 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7180 not_null_expr
, eq_expr
);
7188 /* The following routine generates code for the intrinsic
7189 subroutines from the ISO_C_BINDING module:
7191 * C_F_PROCPOINTER. */
7194 conv_isocbinding_subroutine (gfc_code
*code
)
7201 tree desc
, dim
, tmp
, stride
, offset
;
7202 stmtblock_t body
, block
;
7204 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7206 gfc_init_se (&se
, NULL
);
7207 gfc_init_se (&cptrse
, NULL
);
7208 gfc_conv_expr (&cptrse
, arg
->expr
);
7209 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7210 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7212 gfc_init_se (&fptrse
, NULL
);
7213 if (arg
->next
->expr
->rank
== 0)
7215 fptrse
.want_pointer
= 1;
7216 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7217 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7218 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7219 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7220 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7221 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7223 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7224 TREE_TYPE (fptrse
.expr
),
7226 fold_convert (TREE_TYPE (fptrse
.expr
),
7228 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7229 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7230 return gfc_finish_block (&se
.pre
);
7233 gfc_start_block (&block
);
7235 /* Get the descriptor of the Fortran pointer. */
7236 fptrse
.descriptor_only
= 1;
7237 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7238 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7241 /* Set data value, dtype, and offset. */
7242 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7243 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7244 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7245 gfc_get_dtype (TREE_TYPE (desc
)));
7247 /* Start scalarization of the bounds, using the shape argument. */
7249 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7250 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7251 gfc_init_se (&shapese
, NULL
);
7253 gfc_init_loopinfo (&loop
);
7254 gfc_add_ss_to_loop (&loop
, shape_ss
);
7255 gfc_conv_ss_startstride (&loop
);
7256 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7257 gfc_mark_ss_chain_used (shape_ss
, 1);
7259 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7260 shapese
.ss
= shape_ss
;
7262 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7263 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7264 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7265 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7268 gfc_start_scalarized_body (&loop
, &body
);
7270 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7271 loop
.loopvar
[0], loop
.from
[0]);
7273 /* Set bounds and stride. */
7274 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7275 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7277 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7278 gfc_add_block_to_block (&body
, &shapese
.pre
);
7279 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7280 gfc_add_block_to_block (&body
, &shapese
.post
);
7282 /* Calculate offset. */
7283 gfc_add_modify (&body
, offset
,
7284 fold_build2_loc (input_location
, PLUS_EXPR
,
7285 gfc_array_index_type
, offset
, stride
));
7286 /* Update stride. */
7287 gfc_add_modify (&body
, stride
,
7288 fold_build2_loc (input_location
, MULT_EXPR
,
7289 gfc_array_index_type
, stride
,
7290 fold_convert (gfc_array_index_type
,
7292 /* Finish scalarization loop. */
7293 gfc_trans_scalarizing_loops (&loop
, &body
);
7294 gfc_add_block_to_block (&block
, &loop
.pre
);
7295 gfc_add_block_to_block (&block
, &loop
.post
);
7296 gfc_add_block_to_block (&block
, &fptrse
.post
);
7297 gfc_cleanup_loop (&loop
);
7299 gfc_add_modify (&block
, offset
,
7300 fold_build1_loc (input_location
, NEGATE_EXPR
,
7301 gfc_array_index_type
, offset
));
7302 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7304 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7305 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7306 return gfc_finish_block (&se
.pre
);
7310 /* Save and restore floating-point state. */
7313 gfc_save_fp_state (stmtblock_t
*block
)
7315 tree type
, fpstate
, tmp
;
7317 type
= build_array_type (char_type_node
,
7318 build_range_type (size_type_node
, size_zero_node
,
7319 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
7320 fpstate
= gfc_create_var (type
, "fpstate");
7321 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
7323 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
7325 gfc_add_expr_to_block (block
, tmp
);
7332 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
7336 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
7338 gfc_add_expr_to_block (block
, tmp
);
7342 /* Generate code for arguments of IEEE functions. */
7345 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
7348 gfc_actual_arglist
*actual
;
7353 actual
= expr
->value
.function
.actual
;
7354 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
7356 gcc_assert (actual
);
7359 gfc_init_se (&argse
, se
);
7360 gfc_conv_expr_val (&argse
, e
);
7362 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7363 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7364 argarray
[arg
] = argse
.expr
;
7369 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7370 and IEEE_UNORDERED, which translate directly to GCC type-generic
7374 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
7375 enum built_in_function code
, int nargs
)
7378 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
7380 conv_ieee_function_args (se
, expr
, args
, nargs
);
7381 se
->expr
= build_call_expr_loc_array (input_location
,
7382 builtin_decl_explicit (code
),
7384 STRIP_TYPE_NOPS (se
->expr
);
7385 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7389 /* Generate code for IEEE_IS_NORMAL intrinsic:
7390 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7393 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
7395 tree arg
, isnormal
, iszero
;
7397 /* Convert arg, evaluate it only once. */
7398 conv_ieee_function_args (se
, expr
, &arg
, 1);
7399 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7401 isnormal
= build_call_expr_loc (input_location
,
7402 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
7404 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
7405 build_real_from_int_cst (TREE_TYPE (arg
),
7406 integer_zero_node
));
7407 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7408 boolean_type_node
, isnormal
, iszero
);
7409 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7413 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7414 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7417 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
7419 tree arg
, signbit
, isnan
, decl
;
7422 /* Convert arg, evaluate it only once. */
7423 conv_ieee_function_args (se
, expr
, &arg
, 1);
7424 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7426 isnan
= build_call_expr_loc (input_location
,
7427 builtin_decl_explicit (BUILT_IN_ISNAN
),
7429 STRIP_TYPE_NOPS (isnan
);
7431 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7432 decl
= builtin_decl_for_precision (BUILT_IN_SIGNBIT
, argprec
);
7433 signbit
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7434 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7435 signbit
, integer_zero_node
);
7437 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7438 boolean_type_node
, signbit
,
7439 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
7440 TREE_TYPE(isnan
), isnan
));
7442 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7446 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7449 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
7450 enum built_in_function code
)
7452 tree arg
, decl
, call
, fpstate
;
7455 conv_ieee_function_args (se
, expr
, &arg
, 1);
7456 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7457 decl
= builtin_decl_for_precision (code
, argprec
);
7459 /* Save floating-point state. */
7460 fpstate
= gfc_save_fp_state (&se
->pre
);
7462 /* Make the function call. */
7463 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7464 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
7466 /* Restore floating-point state. */
7467 gfc_restore_fp_state (&se
->post
, fpstate
);
7471 /* Generate code for IEEE_REM. */
7474 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
7476 tree args
[2], decl
, call
, fpstate
;
7479 conv_ieee_function_args (se
, expr
, args
, 2);
7481 /* If arguments have unequal size, convert them to the larger. */
7482 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
7483 > TYPE_PRECISION (TREE_TYPE (args
[1])))
7484 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7485 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
7486 > TYPE_PRECISION (TREE_TYPE (args
[0])))
7487 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
7489 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7490 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
7492 /* Save floating-point state. */
7493 fpstate
= gfc_save_fp_state (&se
->pre
);
7495 /* Make the function call. */
7496 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7497 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7499 /* Restore floating-point state. */
7500 gfc_restore_fp_state (&se
->post
, fpstate
);
7504 /* Generate code for IEEE_NEXT_AFTER. */
7507 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
7509 tree args
[2], decl
, call
, fpstate
;
7512 conv_ieee_function_args (se
, expr
, args
, 2);
7514 /* Result has the characteristics of first argument. */
7515 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7516 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7517 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
7519 /* Save floating-point state. */
7520 fpstate
= gfc_save_fp_state (&se
->pre
);
7522 /* Make the function call. */
7523 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7524 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7526 /* Restore floating-point state. */
7527 gfc_restore_fp_state (&se
->post
, fpstate
);
7531 /* Generate code for IEEE_SCALB. */
7534 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
7536 tree args
[2], decl
, call
, huge
, type
;
7539 conv_ieee_function_args (se
, expr
, args
, 2);
7541 /* Result has the characteristics of first argument. */
7542 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7543 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
7545 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
7547 /* We need to fold the integer into the range of a C int. */
7548 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7549 type
= TREE_TYPE (args
[1]);
7551 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
7552 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
7554 huge
= fold_convert (type
, huge
);
7555 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
7557 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
7558 fold_build1_loc (input_location
, NEGATE_EXPR
,
7562 args
[1] = fold_convert (integer_type_node
, args
[1]);
7564 /* Make the function call. */
7565 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7566 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7570 /* Generate code for IEEE_COPY_SIGN. */
7573 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
7575 tree args
[2], decl
, sign
;
7578 conv_ieee_function_args (se
, expr
, args
, 2);
7580 /* Get the sign of the second argument. */
7581 argprec
= TYPE_PRECISION (TREE_TYPE (args
[1]));
7582 decl
= builtin_decl_for_precision (BUILT_IN_SIGNBIT
, argprec
);
7583 sign
= build_call_expr_loc (input_location
, decl
, 1, args
[1]);
7584 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7585 sign
, integer_zero_node
);
7587 /* Create a value of one, with the right sign. */
7588 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
7590 fold_build1_loc (input_location
, NEGATE_EXPR
,
7594 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
7596 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7597 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
7599 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7603 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7607 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
7609 const char *name
= expr
->value
.function
.name
;
7611 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7613 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
7614 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
7615 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
7616 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
7617 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
7618 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
7619 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
7620 conv_intrinsic_ieee_is_normal (se
, expr
);
7621 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
7622 conv_intrinsic_ieee_is_negative (se
, expr
);
7623 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
7624 conv_intrinsic_ieee_copy_sign (se
, expr
);
7625 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
7626 conv_intrinsic_ieee_scalb (se
, expr
);
7627 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
7628 conv_intrinsic_ieee_next_after (se
, expr
);
7629 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
7630 conv_intrinsic_ieee_rem (se
, expr
);
7631 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
7632 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
7633 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
7634 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
7636 /* It is not among the functions we translate directly. We return
7637 false, so a library function call is emitted. */
7646 /* Generate code for an intrinsic function. Some map directly to library
7647 calls, others get special handling. In some cases the name of the function
7648 used depends on the type specifiers. */
7651 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7657 name
= &expr
->value
.function
.name
[2];
7661 lib
= gfc_is_intrinsic_libcall (expr
);
7665 se
->ignore_optional
= 1;
7667 switch (expr
->value
.function
.isym
->id
)
7669 case GFC_ISYM_EOSHIFT
:
7671 case GFC_ISYM_RESHAPE
:
7672 /* For all of those the first argument specifies the type and the
7673 third is optional. */
7674 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7678 gfc_conv_intrinsic_funcall (se
, expr
);
7686 switch (expr
->value
.function
.isym
->id
)
7691 case GFC_ISYM_REPEAT
:
7692 gfc_conv_intrinsic_repeat (se
, expr
);
7696 gfc_conv_intrinsic_trim (se
, expr
);
7699 case GFC_ISYM_SC_KIND
:
7700 gfc_conv_intrinsic_sc_kind (se
, expr
);
7703 case GFC_ISYM_SI_KIND
:
7704 gfc_conv_intrinsic_si_kind (se
, expr
);
7707 case GFC_ISYM_SR_KIND
:
7708 gfc_conv_intrinsic_sr_kind (se
, expr
);
7711 case GFC_ISYM_EXPONENT
:
7712 gfc_conv_intrinsic_exponent (se
, expr
);
7716 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7718 fndecl
= gfor_fndecl_string_scan
;
7720 fndecl
= gfor_fndecl_string_scan_char4
;
7724 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7727 case GFC_ISYM_VERIFY
:
7728 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7730 fndecl
= gfor_fndecl_string_verify
;
7732 fndecl
= gfor_fndecl_string_verify_char4
;
7736 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7739 case GFC_ISYM_ALLOCATED
:
7740 gfc_conv_allocated (se
, expr
);
7743 case GFC_ISYM_ASSOCIATED
:
7744 gfc_conv_associated(se
, expr
);
7747 case GFC_ISYM_SAME_TYPE_AS
:
7748 gfc_conv_same_type_as (se
, expr
);
7752 gfc_conv_intrinsic_abs (se
, expr
);
7755 case GFC_ISYM_ADJUSTL
:
7756 if (expr
->ts
.kind
== 1)
7757 fndecl
= gfor_fndecl_adjustl
;
7758 else if (expr
->ts
.kind
== 4)
7759 fndecl
= gfor_fndecl_adjustl_char4
;
7763 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7766 case GFC_ISYM_ADJUSTR
:
7767 if (expr
->ts
.kind
== 1)
7768 fndecl
= gfor_fndecl_adjustr
;
7769 else if (expr
->ts
.kind
== 4)
7770 fndecl
= gfor_fndecl_adjustr_char4
;
7774 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7777 case GFC_ISYM_AIMAG
:
7778 gfc_conv_intrinsic_imagpart (se
, expr
);
7782 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7786 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7789 case GFC_ISYM_ANINT
:
7790 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7794 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7798 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7801 case GFC_ISYM_BTEST
:
7802 gfc_conv_intrinsic_btest (se
, expr
);
7806 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7810 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7814 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7818 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7821 case GFC_ISYM_C_ASSOCIATED
:
7822 case GFC_ISYM_C_FUNLOC
:
7823 case GFC_ISYM_C_LOC
:
7824 conv_isocbinding_function (se
, expr
);
7827 case GFC_ISYM_ACHAR
:
7829 gfc_conv_intrinsic_char (se
, expr
);
7832 case GFC_ISYM_CONVERSION
:
7834 case GFC_ISYM_LOGICAL
:
7836 gfc_conv_intrinsic_conversion (se
, expr
);
7839 /* Integer conversions are handled separately to make sure we get the
7840 correct rounding mode. */
7845 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7849 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7852 case GFC_ISYM_CEILING
:
7853 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7856 case GFC_ISYM_FLOOR
:
7857 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7861 gfc_conv_intrinsic_mod (se
, expr
, 0);
7864 case GFC_ISYM_MODULO
:
7865 gfc_conv_intrinsic_mod (se
, expr
, 1);
7868 case GFC_ISYM_CAF_GET
:
7869 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
);
7872 case GFC_ISYM_CMPLX
:
7873 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7876 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7877 gfc_conv_intrinsic_iargc (se
, expr
);
7880 case GFC_ISYM_COMPLEX
:
7881 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7884 case GFC_ISYM_CONJG
:
7885 gfc_conv_intrinsic_conjg (se
, expr
);
7888 case GFC_ISYM_COUNT
:
7889 gfc_conv_intrinsic_count (se
, expr
);
7892 case GFC_ISYM_CTIME
:
7893 gfc_conv_intrinsic_ctime (se
, expr
);
7897 gfc_conv_intrinsic_dim (se
, expr
);
7900 case GFC_ISYM_DOT_PRODUCT
:
7901 gfc_conv_intrinsic_dot_product (se
, expr
);
7904 case GFC_ISYM_DPROD
:
7905 gfc_conv_intrinsic_dprod (se
, expr
);
7908 case GFC_ISYM_DSHIFTL
:
7909 gfc_conv_intrinsic_dshift (se
, expr
, true);
7912 case GFC_ISYM_DSHIFTR
:
7913 gfc_conv_intrinsic_dshift (se
, expr
, false);
7916 case GFC_ISYM_FDATE
:
7917 gfc_conv_intrinsic_fdate (se
, expr
);
7920 case GFC_ISYM_FRACTION
:
7921 gfc_conv_intrinsic_fraction (se
, expr
);
7925 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7929 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7933 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
7936 case GFC_ISYM_IBCLR
:
7937 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
7940 case GFC_ISYM_IBITS
:
7941 gfc_conv_intrinsic_ibits (se
, expr
);
7944 case GFC_ISYM_IBSET
:
7945 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
7948 case GFC_ISYM_IACHAR
:
7949 case GFC_ISYM_ICHAR
:
7950 /* We assume ASCII character sequence. */
7951 gfc_conv_intrinsic_ichar (se
, expr
);
7954 case GFC_ISYM_IARGC
:
7955 gfc_conv_intrinsic_iargc (se
, expr
);
7959 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7962 case GFC_ISYM_INDEX
:
7963 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7965 fndecl
= gfor_fndecl_string_index
;
7967 fndecl
= gfor_fndecl_string_index_char4
;
7971 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7975 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7978 case GFC_ISYM_IPARITY
:
7979 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
7982 case GFC_ISYM_IS_IOSTAT_END
:
7983 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
7986 case GFC_ISYM_IS_IOSTAT_EOR
:
7987 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
7990 case GFC_ISYM_ISNAN
:
7991 gfc_conv_intrinsic_isnan (se
, expr
);
7994 case GFC_ISYM_LSHIFT
:
7995 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7998 case GFC_ISYM_RSHIFT
:
7999 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8002 case GFC_ISYM_SHIFTA
:
8003 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8006 case GFC_ISYM_SHIFTL
:
8007 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8010 case GFC_ISYM_SHIFTR
:
8011 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8014 case GFC_ISYM_ISHFT
:
8015 gfc_conv_intrinsic_ishft (se
, expr
);
8018 case GFC_ISYM_ISHFTC
:
8019 gfc_conv_intrinsic_ishftc (se
, expr
);
8022 case GFC_ISYM_LEADZ
:
8023 gfc_conv_intrinsic_leadz (se
, expr
);
8026 case GFC_ISYM_TRAILZ
:
8027 gfc_conv_intrinsic_trailz (se
, expr
);
8030 case GFC_ISYM_POPCNT
:
8031 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8034 case GFC_ISYM_POPPAR
:
8035 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8038 case GFC_ISYM_LBOUND
:
8039 gfc_conv_intrinsic_bound (se
, expr
, 0);
8042 case GFC_ISYM_LCOBOUND
:
8043 conv_intrinsic_cobound (se
, expr
);
8046 case GFC_ISYM_TRANSPOSE
:
8047 /* The scalarizer has already been set up for reversed dimension access
8048 order ; now we just get the argument value normally. */
8049 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8053 gfc_conv_intrinsic_len (se
, expr
);
8056 case GFC_ISYM_LEN_TRIM
:
8057 gfc_conv_intrinsic_len_trim (se
, expr
);
8061 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8065 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8069 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8073 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8076 case GFC_ISYM_MASKL
:
8077 gfc_conv_intrinsic_mask (se
, expr
, 1);
8080 case GFC_ISYM_MASKR
:
8081 gfc_conv_intrinsic_mask (se
, expr
, 0);
8085 if (expr
->ts
.type
== BT_CHARACTER
)
8086 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8088 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8091 case GFC_ISYM_MAXLOC
:
8092 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8095 case GFC_ISYM_MAXVAL
:
8096 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8099 case GFC_ISYM_MERGE
:
8100 gfc_conv_intrinsic_merge (se
, expr
);
8103 case GFC_ISYM_MERGE_BITS
:
8104 gfc_conv_intrinsic_merge_bits (se
, expr
);
8108 if (expr
->ts
.type
== BT_CHARACTER
)
8109 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8111 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8114 case GFC_ISYM_MINLOC
:
8115 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8118 case GFC_ISYM_MINVAL
:
8119 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8122 case GFC_ISYM_NEAREST
:
8123 gfc_conv_intrinsic_nearest (se
, expr
);
8126 case GFC_ISYM_NORM2
:
8127 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8131 gfc_conv_intrinsic_not (se
, expr
);
8135 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8138 case GFC_ISYM_PARITY
:
8139 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8142 case GFC_ISYM_PRESENT
:
8143 gfc_conv_intrinsic_present (se
, expr
);
8146 case GFC_ISYM_PRODUCT
:
8147 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8151 gfc_conv_intrinsic_rank (se
, expr
);
8154 case GFC_ISYM_RRSPACING
:
8155 gfc_conv_intrinsic_rrspacing (se
, expr
);
8158 case GFC_ISYM_SET_EXPONENT
:
8159 gfc_conv_intrinsic_set_exponent (se
, expr
);
8162 case GFC_ISYM_SCALE
:
8163 gfc_conv_intrinsic_scale (se
, expr
);
8167 gfc_conv_intrinsic_sign (se
, expr
);
8171 gfc_conv_intrinsic_size (se
, expr
);
8174 case GFC_ISYM_SIZEOF
:
8175 case GFC_ISYM_C_SIZEOF
:
8176 gfc_conv_intrinsic_sizeof (se
, expr
);
8179 case GFC_ISYM_STORAGE_SIZE
:
8180 gfc_conv_intrinsic_storage_size (se
, expr
);
8183 case GFC_ISYM_SPACING
:
8184 gfc_conv_intrinsic_spacing (se
, expr
);
8187 case GFC_ISYM_STRIDE
:
8188 conv_intrinsic_stride (se
, expr
);
8192 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8195 case GFC_ISYM_TRANSFER
:
8196 if (se
->ss
&& se
->ss
->info
->useflags
)
8197 /* Access the previously obtained result. */
8198 gfc_conv_tmp_array_ref (se
);
8200 gfc_conv_intrinsic_transfer (se
, expr
);
8203 case GFC_ISYM_TTYNAM
:
8204 gfc_conv_intrinsic_ttynam (se
, expr
);
8207 case GFC_ISYM_UBOUND
:
8208 gfc_conv_intrinsic_bound (se
, expr
, 1);
8211 case GFC_ISYM_UCOBOUND
:
8212 conv_intrinsic_cobound (se
, expr
);
8216 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8220 gfc_conv_intrinsic_loc (se
, expr
);
8223 case GFC_ISYM_THIS_IMAGE
:
8224 /* For num_images() == 1, handle as LCOBOUND. */
8225 if (expr
->value
.function
.actual
->expr
8226 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
8227 conv_intrinsic_cobound (se
, expr
);
8229 trans_this_image (se
, expr
);
8232 case GFC_ISYM_IMAGE_INDEX
:
8233 trans_image_index (se
, expr
);
8236 case GFC_ISYM_NUM_IMAGES
:
8237 trans_num_images (se
, expr
);
8240 case GFC_ISYM_ACCESS
:
8241 case GFC_ISYM_CHDIR
:
8242 case GFC_ISYM_CHMOD
:
8243 case GFC_ISYM_DTIME
:
8244 case GFC_ISYM_ETIME
:
8245 case GFC_ISYM_EXTENDS_TYPE_OF
:
8247 case GFC_ISYM_FGETC
:
8250 case GFC_ISYM_FPUTC
:
8251 case GFC_ISYM_FSTAT
:
8252 case GFC_ISYM_FTELL
:
8253 case GFC_ISYM_GETCWD
:
8254 case GFC_ISYM_GETGID
:
8255 case GFC_ISYM_GETPID
:
8256 case GFC_ISYM_GETUID
:
8257 case GFC_ISYM_HOSTNM
:
8259 case GFC_ISYM_IERRNO
:
8260 case GFC_ISYM_IRAND
:
8261 case GFC_ISYM_ISATTY
:
8264 case GFC_ISYM_LSTAT
:
8265 case GFC_ISYM_MALLOC
:
8266 case GFC_ISYM_MATMUL
:
8267 case GFC_ISYM_MCLOCK
:
8268 case GFC_ISYM_MCLOCK8
:
8270 case GFC_ISYM_RENAME
:
8271 case GFC_ISYM_SECOND
:
8272 case GFC_ISYM_SECNDS
:
8273 case GFC_ISYM_SIGNAL
:
8275 case GFC_ISYM_SYMLNK
:
8276 case GFC_ISYM_SYSTEM
:
8278 case GFC_ISYM_TIME8
:
8279 case GFC_ISYM_UMASK
:
8280 case GFC_ISYM_UNLINK
:
8282 gfc_conv_intrinsic_funcall (se
, expr
);
8285 case GFC_ISYM_EOSHIFT
:
8287 case GFC_ISYM_RESHAPE
:
8288 /* For those, expr->rank should always be >0 and thus the if above the
8289 switch should have matched. */
8294 gfc_conv_intrinsic_lib_function (se
, expr
);
8301 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
8303 gfc_ss
*arg_ss
, *tmp_ss
;
8304 gfc_actual_arglist
*arg
;
8306 arg
= expr
->value
.function
.actual
;
8308 gcc_assert (arg
->expr
);
8310 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
8311 gcc_assert (arg_ss
!= gfc_ss_terminator
);
8313 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
8315 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
8316 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
8318 gcc_assert (tmp_ss
->dimen
== 2);
8320 /* We just invert dimensions. */
8321 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
8324 /* Stop when tmp_ss points to the last valid element of the chain... */
8325 if (tmp_ss
->next
== gfc_ss_terminator
)
8329 /* ... so that we can attach the rest of the chain to it. */
8336 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8337 This has the side effect of reversing the nested list, so there is no
8338 need to call gfc_reverse_ss on it (the given list is assumed not to be
8342 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8345 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8346 gfc_loopinfo
*new_loop
;
8348 gcc_assert (ss
!= gfc_ss_terminator
);
8350 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8352 new_ss
= gfc_get_ss ();
8353 new_ss
->next
= prev_ss
;
8354 new_ss
->parent
= ss
;
8355 new_ss
->info
= ss
->info
;
8356 new_ss
->info
->refcount
++;
8359 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8360 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8363 new_ss
->dim
[0] = ss
->dim
[dim
];
8365 gcc_assert (dim
< ss
->dimen
);
8367 ss_dim
= --ss
->dimen
;
8368 for (i
= dim
; i
< ss_dim
; i
++)
8369 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8371 ss
->dim
[ss_dim
] = 0;
8377 ss
->nested_ss
->parent
= new_ss
;
8378 new_ss
->nested_ss
= ss
->nested_ss
;
8380 ss
->nested_ss
= new_ss
;
8383 new_loop
= gfc_get_loopinfo ();
8384 gfc_init_loopinfo (new_loop
);
8386 gcc_assert (prev_ss
!= NULL
);
8387 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8388 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8389 return new_ss
->parent
;
8393 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8394 is to be inlined. */
8397 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8399 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8400 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8402 bool scalar_mask
= false;
8404 /* The rank of the result will be determined later. */
8405 arg1
= expr
->value
.function
.actual
;
8408 gcc_assert (arg3
!= NULL
);
8410 if (expr
->rank
== 0)
8413 tmp_ss
= gfc_ss_terminator
;
8419 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8420 if (mask_ss
== tmp_ss
)
8426 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8427 gcc_assert (array_ss
!= tmp_ss
);
8429 /* Odd thing: If the mask is scalar, it is used by the frontend after
8430 the array (to make an if around the nested loop). Thus it shall
8431 be after array_ss once the gfc_ss list is reversed. */
8433 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8437 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8439 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8440 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8448 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8451 switch (expr
->value
.function
.isym
->id
)
8453 case GFC_ISYM_PRODUCT
:
8455 return walk_inline_intrinsic_arith (ss
, expr
);
8457 case GFC_ISYM_TRANSPOSE
:
8458 return walk_inline_intrinsic_transpose (ss
, expr
);
8467 /* This generates code to execute before entering the scalarization loop.
8468 Currently does nothing. */
8471 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8473 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8475 case GFC_ISYM_UBOUND
:
8476 case GFC_ISYM_LBOUND
:
8477 case GFC_ISYM_UCOBOUND
:
8478 case GFC_ISYM_LCOBOUND
:
8479 case GFC_ISYM_THIS_IMAGE
:
8488 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8489 are expanded into code inside the scalarization loop. */
8492 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8494 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8495 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8497 /* The two argument version returns a scalar. */
8498 if (expr
->value
.function
.actual
->next
->expr
)
8501 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8505 /* Walk an intrinsic array libcall. */
8508 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8510 gcc_assert (expr
->rank
> 0);
8511 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8515 /* Return whether the function call expression EXPR will be expanded
8516 inline by gfc_conv_intrinsic_function. */
8519 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8521 gfc_actual_arglist
*args
;
8523 if (!expr
->value
.function
.isym
)
8526 switch (expr
->value
.function
.isym
->id
)
8528 case GFC_ISYM_PRODUCT
:
8530 /* Disable inline expansion if code size matters. */
8534 args
= expr
->value
.function
.actual
;
8535 /* We need to be able to subset the SUM argument at compile-time. */
8536 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8541 case GFC_ISYM_TRANSPOSE
:
8550 /* Returns nonzero if the specified intrinsic function call maps directly to
8551 an external library call. Should only be used for functions that return
8555 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8557 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8558 gcc_assert (expr
->rank
> 0);
8560 if (gfc_inline_intrinsic_function_p (expr
))
8563 switch (expr
->value
.function
.isym
->id
)
8567 case GFC_ISYM_COUNT
:
8571 case GFC_ISYM_IPARITY
:
8572 case GFC_ISYM_MATMUL
:
8573 case GFC_ISYM_MAXLOC
:
8574 case GFC_ISYM_MAXVAL
:
8575 case GFC_ISYM_MINLOC
:
8576 case GFC_ISYM_MINVAL
:
8577 case GFC_ISYM_NORM2
:
8578 case GFC_ISYM_PARITY
:
8579 case GFC_ISYM_PRODUCT
:
8581 case GFC_ISYM_SHAPE
:
8582 case GFC_ISYM_SPREAD
:
8584 /* Ignore absent optional parameters. */
8587 case GFC_ISYM_RESHAPE
:
8588 case GFC_ISYM_CSHIFT
:
8589 case GFC_ISYM_EOSHIFT
:
8591 case GFC_ISYM_UNPACK
:
8592 /* Pass absent optional parameters. */
8600 /* Walk an intrinsic function. */
8602 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8603 gfc_intrinsic_sym
* isym
)
8607 if (isym
->elemental
)
8608 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8609 NULL
, GFC_SS_SCALAR
);
8611 if (expr
->rank
== 0)
8614 if (gfc_inline_intrinsic_function_p (expr
))
8615 return walk_inline_intrinsic_function (ss
, expr
);
8617 if (gfc_is_intrinsic_libcall (expr
))
8618 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8620 /* Special cases. */
8623 case GFC_ISYM_LBOUND
:
8624 case GFC_ISYM_LCOBOUND
:
8625 case GFC_ISYM_UBOUND
:
8626 case GFC_ISYM_UCOBOUND
:
8627 case GFC_ISYM_THIS_IMAGE
:
8628 return gfc_walk_intrinsic_bound (ss
, expr
);
8630 case GFC_ISYM_TRANSFER
:
8631 case GFC_ISYM_CAF_GET
:
8632 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8635 /* This probably meant someone forgot to add an intrinsic to the above
8636 list(s) when they implemented it, or something's gone horribly
8644 conv_co_collective (gfc_code
*code
)
8647 stmtblock_t block
, post_block
;
8648 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8649 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
8651 gfc_start_block (&block
);
8652 gfc_init_block (&post_block
);
8654 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
8656 opr_expr
= code
->ext
.actual
->next
->expr
;
8657 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
8658 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8659 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
8664 image_idx_expr
= code
->ext
.actual
->next
->expr
;
8665 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8666 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8672 gfc_init_se (&argse
, NULL
);
8673 gfc_conv_expr (&argse
, stat_expr
);
8674 gfc_add_block_to_block (&block
, &argse
.pre
);
8675 gfc_add_block_to_block (&post_block
, &argse
.post
);
8677 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8678 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8680 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8683 stat
= null_pointer_node
;
8685 /* Early exit for GFC_FCOARRAY_SINGLE. */
8686 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8688 if (stat
!= NULL_TREE
)
8689 gfc_add_modify (&block
, stat
,
8690 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8691 return gfc_finish_block (&block
);
8694 /* Handle the array. */
8695 gfc_init_se (&argse
, NULL
);
8696 if (code
->ext
.actual
->expr
->rank
== 0)
8698 symbol_attribute attr
;
8699 gfc_clear_attr (&attr
);
8700 gfc_init_se (&argse
, NULL
);
8701 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8702 gfc_add_block_to_block (&block
, &argse
.pre
);
8703 gfc_add_block_to_block (&post_block
, &argse
.post
);
8704 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8705 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8709 argse
.want_pointer
= 1;
8710 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8713 gfc_add_block_to_block (&block
, &argse
.pre
);
8714 gfc_add_block_to_block (&post_block
, &argse
.post
);
8716 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8717 strlen
= argse
.string_length
;
8719 strlen
= integer_zero_node
;
8724 gfc_init_se (&argse
, NULL
);
8725 gfc_conv_expr (&argse
, image_idx_expr
);
8726 gfc_add_block_to_block (&block
, &argse
.pre
);
8727 gfc_add_block_to_block (&post_block
, &argse
.post
);
8728 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8731 image_index
= integer_zero_node
;
8736 gfc_init_se (&argse
, NULL
);
8737 gfc_conv_expr (&argse
, errmsg_expr
);
8738 gfc_add_block_to_block (&block
, &argse
.pre
);
8739 gfc_add_block_to_block (&post_block
, &argse
.post
);
8740 errmsg
= argse
.expr
;
8741 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8745 errmsg
= null_pointer_node
;
8746 errmsg_len
= integer_zero_node
;
8749 /* Generate the function call. */
8750 switch (code
->resolved_isym
->id
)
8752 case GFC_ISYM_CO_BROADCAST
:
8753 fndecl
= gfor_fndecl_co_broadcast
;
8755 case GFC_ISYM_CO_MAX
:
8756 fndecl
= gfor_fndecl_co_max
;
8758 case GFC_ISYM_CO_MIN
:
8759 fndecl
= gfor_fndecl_co_min
;
8761 case GFC_ISYM_CO_REDUCE
:
8762 fndecl
= gfor_fndecl_co_reduce
;
8764 case GFC_ISYM_CO_SUM
:
8765 fndecl
= gfor_fndecl_co_sum
;
8771 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
8772 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
8773 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8774 image_index
, stat
, errmsg
, errmsg_len
);
8775 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
8776 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8777 stat
, errmsg
, strlen
, errmsg_len
);
8780 tree opr
, opr_flags
;
8782 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8784 if (gfc_is_proc_ptr_comp (opr_expr
))
8786 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
8787 opr_flag_int
= sym
->attr
.dimension
8788 || (sym
->ts
.type
== BT_CHARACTER
8789 && !sym
->attr
.is_bind_c
)
8790 ? GFC_CAF_BYREF
: 0;
8791 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8792 && !sym
->attr
.is_bind_c
8793 ? GFC_CAF_HIDDENLEN
: 0;
8794 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
8798 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
8799 ? GFC_CAF_BYREF
: 0;
8800 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8801 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
8802 ? GFC_CAF_HIDDENLEN
: 0;
8803 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
8804 ? GFC_CAF_ARG_VALUE
: 0;
8806 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
8807 gfc_conv_expr (&argse
, opr_expr
);
8808 opr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
8809 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
8810 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
8813 gfc_add_expr_to_block (&block
, fndecl
);
8814 gfc_add_block_to_block (&block
, &post_block
);
8816 return gfc_finish_block (&block
);
8821 conv_intrinsic_atomic_op (gfc_code
*code
)
8824 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8825 stmtblock_t block
, post_block
;
8826 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8827 gfc_expr
*stat_expr
;
8828 built_in_function fn
;
8830 if (atom_expr
->expr_type
== EXPR_FUNCTION
8831 && atom_expr
->value
.function
.isym
8832 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8833 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8835 gfc_start_block (&block
);
8836 gfc_init_block (&post_block
);
8838 gfc_init_se (&argse
, NULL
);
8839 argse
.want_pointer
= 1;
8840 gfc_conv_expr (&argse
, atom_expr
);
8841 gfc_add_block_to_block (&block
, &argse
.pre
);
8842 gfc_add_block_to_block (&post_block
, &argse
.post
);
8845 gfc_init_se (&argse
, NULL
);
8846 if (flag_coarray
== GFC_FCOARRAY_LIB
8847 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8848 argse
.want_pointer
= 1;
8849 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8850 gfc_add_block_to_block (&block
, &argse
.pre
);
8851 gfc_add_block_to_block (&post_block
, &argse
.post
);
8854 switch (code
->resolved_isym
->id
)
8856 case GFC_ISYM_ATOMIC_ADD
:
8857 case GFC_ISYM_ATOMIC_AND
:
8858 case GFC_ISYM_ATOMIC_DEF
:
8859 case GFC_ISYM_ATOMIC_OR
:
8860 case GFC_ISYM_ATOMIC_XOR
:
8861 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8862 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8863 old
= null_pointer_node
;
8866 gfc_init_se (&argse
, NULL
);
8867 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8868 argse
.want_pointer
= 1;
8869 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8870 gfc_add_block_to_block (&block
, &argse
.pre
);
8871 gfc_add_block_to_block (&post_block
, &argse
.post
);
8873 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8877 if (stat_expr
!= NULL
)
8879 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8880 gfc_init_se (&argse
, NULL
);
8881 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8882 argse
.want_pointer
= 1;
8883 gfc_conv_expr_val (&argse
, stat_expr
);
8884 gfc_add_block_to_block (&block
, &argse
.pre
);
8885 gfc_add_block_to_block (&post_block
, &argse
.post
);
8888 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
8889 stat
= null_pointer_node
;
8891 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8893 tree image_index
, caf_decl
, offset
, token
;
8896 switch (code
->resolved_isym
->id
)
8898 case GFC_ISYM_ATOMIC_ADD
:
8899 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8900 op
= (int) GFC_CAF_ATOMIC_ADD
;
8902 case GFC_ISYM_ATOMIC_AND
:
8903 case GFC_ISYM_ATOMIC_FETCH_AND
:
8904 op
= (int) GFC_CAF_ATOMIC_AND
;
8906 case GFC_ISYM_ATOMIC_OR
:
8907 case GFC_ISYM_ATOMIC_FETCH_OR
:
8908 op
= (int) GFC_CAF_ATOMIC_OR
;
8910 case GFC_ISYM_ATOMIC_XOR
:
8911 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8912 op
= (int) GFC_CAF_ATOMIC_XOR
;
8914 case GFC_ISYM_ATOMIC_DEF
:
8915 op
= 0; /* Unused. */
8921 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8922 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8923 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8925 if (gfc_is_coindexed (atom_expr
))
8926 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
8928 image_index
= integer_zero_node
;
8930 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
8932 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
8933 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
8934 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8937 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8939 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
8940 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
8941 token
, offset
, image_index
, value
, stat
,
8942 build_int_cst (integer_type_node
,
8943 (int) atom_expr
->ts
.type
),
8944 build_int_cst (integer_type_node
,
8945 (int) atom_expr
->ts
.kind
));
8947 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
8948 build_int_cst (integer_type_node
, op
),
8949 token
, offset
, image_index
, value
, old
, stat
,
8950 build_int_cst (integer_type_node
,
8951 (int) atom_expr
->ts
.type
),
8952 build_int_cst (integer_type_node
,
8953 (int) atom_expr
->ts
.kind
));
8955 gfc_add_expr_to_block (&block
, tmp
);
8956 gfc_add_block_to_block (&block
, &post_block
);
8957 return gfc_finish_block (&block
);
8961 switch (code
->resolved_isym
->id
)
8963 case GFC_ISYM_ATOMIC_ADD
:
8964 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8965 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
8967 case GFC_ISYM_ATOMIC_AND
:
8968 case GFC_ISYM_ATOMIC_FETCH_AND
:
8969 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
8971 case GFC_ISYM_ATOMIC_DEF
:
8972 fn
= BUILT_IN_ATOMIC_STORE_N
;
8974 case GFC_ISYM_ATOMIC_OR
:
8975 case GFC_ISYM_ATOMIC_FETCH_OR
:
8976 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
8978 case GFC_ISYM_ATOMIC_XOR
:
8979 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8980 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
8986 tmp
= TREE_TYPE (TREE_TYPE (atom
));
8987 fn
= (built_in_function
) ((int) fn
8988 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
8990 tmp
= builtin_decl_explicit (fn
);
8991 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
8992 tmp
= builtin_decl_explicit (fn
);
8994 switch (code
->resolved_isym
->id
)
8996 case GFC_ISYM_ATOMIC_ADD
:
8997 case GFC_ISYM_ATOMIC_AND
:
8998 case GFC_ISYM_ATOMIC_DEF
:
8999 case GFC_ISYM_ATOMIC_OR
:
9000 case GFC_ISYM_ATOMIC_XOR
:
9001 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9002 fold_convert (itype
, value
),
9003 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9004 gfc_add_expr_to_block (&block
, tmp
);
9007 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9008 fold_convert (itype
, value
),
9009 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9010 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9014 if (stat
!= NULL_TREE
)
9015 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9016 gfc_add_block_to_block (&block
, &post_block
);
9017 return gfc_finish_block (&block
);
9022 conv_intrinsic_atomic_ref (gfc_code
*code
)
9025 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9026 stmtblock_t block
, post_block
;
9027 built_in_function fn
;
9028 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9030 if (atom_expr
->expr_type
== EXPR_FUNCTION
9031 && atom_expr
->value
.function
.isym
9032 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9033 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9035 gfc_start_block (&block
);
9036 gfc_init_block (&post_block
);
9037 gfc_init_se (&argse
, NULL
);
9038 argse
.want_pointer
= 1;
9039 gfc_conv_expr (&argse
, atom_expr
);
9040 gfc_add_block_to_block (&block
, &argse
.pre
);
9041 gfc_add_block_to_block (&post_block
, &argse
.post
);
9044 gfc_init_se (&argse
, NULL
);
9045 if (flag_coarray
== GFC_FCOARRAY_LIB
9046 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9047 argse
.want_pointer
= 1;
9048 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9049 gfc_add_block_to_block (&block
, &argse
.pre
);
9050 gfc_add_block_to_block (&post_block
, &argse
.post
);
9054 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9056 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9058 gfc_init_se (&argse
, NULL
);
9059 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9060 argse
.want_pointer
= 1;
9061 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9062 gfc_add_block_to_block (&block
, &argse
.pre
);
9063 gfc_add_block_to_block (&post_block
, &argse
.post
);
9066 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9067 stat
= null_pointer_node
;
9069 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9071 tree image_index
, caf_decl
, offset
, token
;
9072 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9074 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9075 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9076 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9078 if (gfc_is_coindexed (atom_expr
))
9079 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9081 image_index
= integer_zero_node
;
9083 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9085 /* Different type, need type conversion. */
9086 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9088 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9090 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9093 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9094 token
, offset
, image_index
, value
, stat
,
9095 build_int_cst (integer_type_node
,
9096 (int) atom_expr
->ts
.type
),
9097 build_int_cst (integer_type_node
,
9098 (int) atom_expr
->ts
.kind
));
9099 gfc_add_expr_to_block (&block
, tmp
);
9100 if (vardecl
!= NULL_TREE
)
9101 gfc_add_modify (&block
, orig_value
,
9102 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9103 gfc_add_block_to_block (&block
, &post_block
);
9104 return gfc_finish_block (&block
);
9107 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9108 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9109 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9111 tmp
= builtin_decl_explicit (fn
);
9112 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9113 build_int_cst (integer_type_node
,
9115 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9117 if (stat
!= NULL_TREE
)
9118 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9119 gfc_add_block_to_block (&block
, &post_block
);
9120 return gfc_finish_block (&block
);
9125 conv_intrinsic_atomic_cas (gfc_code
*code
)
9128 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9129 stmtblock_t block
, post_block
;
9130 built_in_function fn
;
9131 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9133 if (atom_expr
->expr_type
== EXPR_FUNCTION
9134 && atom_expr
->value
.function
.isym
9135 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9136 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9138 gfc_init_block (&block
);
9139 gfc_init_block (&post_block
);
9140 gfc_init_se (&argse
, NULL
);
9141 argse
.want_pointer
= 1;
9142 gfc_conv_expr (&argse
, atom_expr
);
9145 gfc_init_se (&argse
, NULL
);
9146 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9147 argse
.want_pointer
= 1;
9148 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9149 gfc_add_block_to_block (&block
, &argse
.pre
);
9150 gfc_add_block_to_block (&post_block
, &argse
.post
);
9153 gfc_init_se (&argse
, NULL
);
9154 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9155 argse
.want_pointer
= 1;
9156 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9157 gfc_add_block_to_block (&block
, &argse
.pre
);
9158 gfc_add_block_to_block (&post_block
, &argse
.post
);
9161 gfc_init_se (&argse
, NULL
);
9162 if (flag_coarray
== GFC_FCOARRAY_LIB
9163 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9164 == atom_expr
->ts
.kind
)
9165 argse
.want_pointer
= 1;
9166 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9167 gfc_add_block_to_block (&block
, &argse
.pre
);
9168 gfc_add_block_to_block (&post_block
, &argse
.post
);
9169 new_val
= argse
.expr
;
9172 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9174 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9176 gfc_init_se (&argse
, NULL
);
9177 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9178 argse
.want_pointer
= 1;
9179 gfc_conv_expr_val (&argse
,
9180 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9181 gfc_add_block_to_block (&block
, &argse
.pre
);
9182 gfc_add_block_to_block (&post_block
, &argse
.post
);
9185 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9186 stat
= null_pointer_node
;
9188 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9190 tree image_index
, caf_decl
, offset
, token
;
9192 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9193 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9194 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9196 if (gfc_is_coindexed (atom_expr
))
9197 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9199 image_index
= integer_zero_node
;
9201 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9203 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9204 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9205 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9208 /* Convert a constant to a pointer. */
9209 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
9211 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
9212 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
9213 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9216 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9218 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
9219 token
, offset
, image_index
, old
, comp
, new_val
,
9220 stat
, build_int_cst (integer_type_node
,
9221 (int) atom_expr
->ts
.type
),
9222 build_int_cst (integer_type_node
,
9223 (int) atom_expr
->ts
.kind
));
9224 gfc_add_expr_to_block (&block
, tmp
);
9225 gfc_add_block_to_block (&block
, &post_block
);
9226 return gfc_finish_block (&block
);
9229 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9230 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9231 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9233 tmp
= builtin_decl_explicit (fn
);
9235 gfc_add_modify (&block
, old
, comp
);
9236 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
9237 gfc_build_addr_expr (NULL
, old
),
9238 fold_convert (TREE_TYPE (old
), new_val
),
9240 build_int_cst (NULL
, MEMMODEL_RELAXED
),
9241 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9242 gfc_add_expr_to_block (&block
, tmp
);
9244 if (stat
!= NULL_TREE
)
9245 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9246 gfc_add_block_to_block (&block
, &post_block
);
9247 return gfc_finish_block (&block
);
9252 conv_intrinsic_move_alloc (gfc_code
*code
)
9255 gfc_expr
*from_expr
, *to_expr
;
9256 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
9257 gfc_se from_se
, to_se
;
9261 gfc_start_block (&block
);
9263 from_expr
= code
->ext
.actual
->expr
;
9264 to_expr
= code
->ext
.actual
->next
->expr
;
9266 gfc_init_se (&from_se
, NULL
);
9267 gfc_init_se (&to_se
, NULL
);
9269 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
9270 || to_expr
->ts
.type
== BT_CLASS
);
9271 coarray
= gfc_get_corank (from_expr
) != 0;
9273 if (from_expr
->rank
== 0 && !coarray
)
9275 if (from_expr
->ts
.type
!= BT_CLASS
)
9276 from_expr2
= from_expr
;
9279 from_expr2
= gfc_copy_expr (from_expr
);
9280 gfc_add_data_component (from_expr2
);
9283 if (to_expr
->ts
.type
!= BT_CLASS
)
9287 to_expr2
= gfc_copy_expr (to_expr
);
9288 gfc_add_data_component (to_expr2
);
9291 from_se
.want_pointer
= 1;
9292 to_se
.want_pointer
= 1;
9293 gfc_conv_expr (&from_se
, from_expr2
);
9294 gfc_conv_expr (&to_se
, to_expr2
);
9295 gfc_add_block_to_block (&block
, &from_se
.pre
);
9296 gfc_add_block_to_block (&block
, &to_se
.pre
);
9298 /* Deallocate "to". */
9299 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
9300 to_expr
, to_expr
->ts
);
9301 gfc_add_expr_to_block (&block
, tmp
);
9303 /* Assign (_data) pointers. */
9304 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9305 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
9307 /* Set "from" to NULL. */
9308 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9309 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
9311 gfc_add_block_to_block (&block
, &from_se
.post
);
9312 gfc_add_block_to_block (&block
, &to_se
.post
);
9315 if (to_expr
->ts
.type
== BT_CLASS
)
9319 gfc_free_expr (to_expr2
);
9320 gfc_init_se (&to_se
, NULL
);
9321 to_se
.want_pointer
= 1;
9322 gfc_add_vptr_component (to_expr
);
9323 gfc_conv_expr (&to_se
, to_expr
);
9325 if (from_expr
->ts
.type
== BT_CLASS
)
9327 if (UNLIMITED_POLY (from_expr
))
9331 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9335 gfc_free_expr (from_expr2
);
9336 gfc_init_se (&from_se
, NULL
);
9337 from_se
.want_pointer
= 1;
9338 gfc_add_vptr_component (from_expr
);
9339 gfc_conv_expr (&from_se
, from_expr
);
9340 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9341 fold_convert (TREE_TYPE (to_se
.expr
),
9344 /* Reset _vptr component to declared type. */
9346 /* Unlimited polymorphic. */
9347 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9348 fold_convert (TREE_TYPE (from_se
.expr
),
9349 null_pointer_node
));
9352 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9353 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9354 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9359 vtab
= gfc_find_vtab (&from_expr
->ts
);
9361 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9362 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9363 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9367 return gfc_finish_block (&block
);
9370 /* Update _vptr component. */
9371 if (to_expr
->ts
.type
== BT_CLASS
)
9375 to_se
.want_pointer
= 1;
9376 to_expr2
= gfc_copy_expr (to_expr
);
9377 gfc_add_vptr_component (to_expr2
);
9378 gfc_conv_expr (&to_se
, to_expr2
);
9380 if (from_expr
->ts
.type
== BT_CLASS
)
9382 if (UNLIMITED_POLY (from_expr
))
9386 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9390 from_se
.want_pointer
= 1;
9391 from_expr2
= gfc_copy_expr (from_expr
);
9392 gfc_add_vptr_component (from_expr2
);
9393 gfc_conv_expr (&from_se
, from_expr2
);
9394 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9395 fold_convert (TREE_TYPE (to_se
.expr
),
9398 /* Reset _vptr component to declared type. */
9400 /* Unlimited polymorphic. */
9401 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9402 fold_convert (TREE_TYPE (from_se
.expr
),
9403 null_pointer_node
));
9406 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9407 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9408 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9413 vtab
= gfc_find_vtab (&from_expr
->ts
);
9415 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9416 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9417 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9420 gfc_free_expr (to_expr2
);
9421 gfc_init_se (&to_se
, NULL
);
9423 if (from_expr
->ts
.type
== BT_CLASS
)
9425 gfc_free_expr (from_expr2
);
9426 gfc_init_se (&from_se
, NULL
);
9431 /* Deallocate "to". */
9432 if (from_expr
->rank
== 0)
9434 to_se
.want_coarray
= 1;
9435 from_se
.want_coarray
= 1;
9437 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9438 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9440 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9441 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9442 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9446 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9447 NULL_TREE
, NULL_TREE
, true, to_expr
,
9449 gfc_add_expr_to_block (&block
, tmp
);
9451 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9452 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9453 boolean_type_node
, tmp
,
9454 fold_convert (TREE_TYPE (tmp
),
9455 null_pointer_node
));
9456 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9457 3, null_pointer_node
, null_pointer_node
,
9458 build_int_cst (integer_type_node
, 0));
9460 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9461 tmp
, build_empty_stmt (input_location
));
9462 gfc_add_expr_to_block (&block
, tmp
);
9466 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9467 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9468 NULL_TREE
, true, to_expr
, false);
9469 gfc_add_expr_to_block (&block
, tmp
);
9472 /* Move the pointer and update the array descriptor data. */
9473 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9475 /* Set "from" to NULL. */
9476 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9477 gfc_add_modify_loc (input_location
, &block
, tmp
,
9478 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9480 return gfc_finish_block (&block
);
9485 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9489 gcc_assert (code
->resolved_isym
);
9491 switch (code
->resolved_isym
->id
)
9493 case GFC_ISYM_MOVE_ALLOC
:
9494 res
= conv_intrinsic_move_alloc (code
);
9497 case GFC_ISYM_ATOMIC_CAS
:
9498 res
= conv_intrinsic_atomic_cas (code
);
9501 case GFC_ISYM_ATOMIC_ADD
:
9502 case GFC_ISYM_ATOMIC_AND
:
9503 case GFC_ISYM_ATOMIC_DEF
:
9504 case GFC_ISYM_ATOMIC_OR
:
9505 case GFC_ISYM_ATOMIC_XOR
:
9506 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9507 case GFC_ISYM_ATOMIC_FETCH_AND
:
9508 case GFC_ISYM_ATOMIC_FETCH_OR
:
9509 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9510 res
= conv_intrinsic_atomic_op (code
);
9513 case GFC_ISYM_ATOMIC_REF
:
9514 res
= conv_intrinsic_atomic_ref (code
);
9517 case GFC_ISYM_C_F_POINTER
:
9518 case GFC_ISYM_C_F_PROCPOINTER
:
9519 res
= conv_isocbinding_subroutine (code
);
9522 case GFC_ISYM_CAF_SEND
:
9523 res
= conv_caf_send (code
);
9526 case GFC_ISYM_CO_BROADCAST
:
9527 case GFC_ISYM_CO_MIN
:
9528 case GFC_ISYM_CO_MAX
:
9529 case GFC_ISYM_CO_REDUCE
:
9530 case GFC_ISYM_CO_SUM
:
9531 res
= conv_co_collective (code
);
9534 case GFC_ISYM_SYSTEM_CLOCK
:
9535 res
= conv_intrinsic_system_clock (code
);
9546 #include "gt-fortran-trans-intrinsic.h"