1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
31 #include "diagnostic-core.h" /* For internal_error. */
32 #include "toplev.h" /* For rest_of_decl_compilation. */
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t
{
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in
;
55 enum built_in_function double_built_in
;
56 enum built_in_function long_double_built_in
;
57 enum built_in_function complex_float_built_in
;
58 enum built_in_function complex_double_built_in
;
59 enum built_in_function complex_long_double_built_in
;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available
;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, true, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (NONE
, NULL
, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in
,
142 int i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
155 return (i
== END_BUILTINS
? NULL_TREE
: built_in_decls
[i
]);
160 builtin_decl_for_float_kind (enum built_in_function double_built_in
, int kind
)
162 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
163 return builtin_decl_for_precision (double_built_in
,
164 gfc_real_kinds
[i
].mode_precision
);
168 /* Evaluate the arguments to an intrinsic function. The value
169 of NARGS may be less than the actual number of arguments in EXPR
170 to allow optional "KIND" arguments that are not included in the
171 generated code to be ignored. */
174 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
175 tree
*argarray
, int nargs
)
177 gfc_actual_arglist
*actual
;
179 gfc_intrinsic_arg
*formal
;
183 formal
= expr
->value
.function
.isym
->formal
;
184 actual
= expr
->value
.function
.actual
;
186 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
187 actual
= actual
->next
,
188 formal
= formal
? formal
->next
: NULL
)
192 /* Skip omitted optional arguments. */
199 /* Evaluate the parameter. This will substitute scalarized
200 references automatically. */
201 gfc_init_se (&argse
, se
);
203 if (e
->ts
.type
== BT_CHARACTER
)
205 gfc_conv_expr (&argse
, e
);
206 gfc_conv_string_parameter (&argse
);
207 argarray
[curr_arg
++] = argse
.string_length
;
208 gcc_assert (curr_arg
< nargs
);
211 gfc_conv_expr_val (&argse
, e
);
213 /* If an optional argument is itself an optional dummy argument,
214 check its presence and substitute a null if absent. */
215 if (e
->expr_type
== EXPR_VARIABLE
216 && e
->symtree
->n
.sym
->attr
.optional
219 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
221 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
222 gfc_add_block_to_block (&se
->post
, &argse
.post
);
223 argarray
[curr_arg
] = argse
.expr
;
227 /* Count the number of actual arguments to the intrinsic function EXPR
228 including any "hidden" string length arguments. */
231 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
234 gfc_actual_arglist
*actual
;
236 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
241 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
251 /* Conversions between different types are output by the frontend as
252 intrinsic functions. We implement these directly with inline code. */
255 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
261 nargs
= gfc_intrinsic_argument_list_length (expr
);
262 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
264 /* Evaluate all the arguments passed. Whilst we're only interested in the
265 first one here, there are other parts of the front-end that assume this
266 and will trigger an ICE if it's not the case. */
267 type
= gfc_typenode_for_spec (&expr
->ts
);
268 gcc_assert (expr
->value
.function
.actual
->expr
);
269 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
271 /* Conversion between character kinds involves a call to a library
273 if (expr
->ts
.type
== BT_CHARACTER
)
275 tree fndecl
, var
, addr
, tmp
;
277 if (expr
->ts
.kind
== 1
278 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
279 fndecl
= gfor_fndecl_convert_char4_to_char1
;
280 else if (expr
->ts
.kind
== 4
281 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
282 fndecl
= gfor_fndecl_convert_char1_to_char4
;
286 /* Create the variable storing the converted value. */
287 type
= gfc_get_pchar_type (expr
->ts
.kind
);
288 var
= gfc_create_var (type
, "str");
289 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
291 /* Call the library function that will perform the conversion. */
292 gcc_assert (nargs
>= 2);
293 tmp
= build_call_expr_loc (input_location
,
294 fndecl
, 3, addr
, args
[0], args
[1]);
295 gfc_add_expr_to_block (&se
->pre
, tmp
);
297 /* Free the temporary afterwards. */
298 tmp
= gfc_call_free (var
);
299 gfc_add_expr_to_block (&se
->post
, tmp
);
302 se
->string_length
= args
[0];
307 /* Conversion from complex to non-complex involves taking the real
308 component of the value. */
309 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
310 && expr
->ts
.type
!= BT_COMPLEX
)
314 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
315 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
318 se
->expr
= convert (type
, args
[0]);
321 /* This is needed because the gcc backend only implements
322 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
323 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
324 Similarly for CEILING. */
327 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
334 argtype
= TREE_TYPE (arg
);
335 arg
= gfc_evaluate_now (arg
, pblock
);
337 intval
= convert (type
, arg
);
338 intval
= gfc_evaluate_now (intval
, pblock
);
340 tmp
= convert (argtype
, intval
);
341 cond
= fold_build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
343 tmp
= fold_build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
344 build_int_cst (type
, 1));
345 tmp
= fold_build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
350 /* Round to nearest integer, away from zero. */
353 build_round_expr (tree arg
, tree restype
)
358 int argprec
, resprec
;
360 argtype
= TREE_TYPE (arg
);
361 argprec
= TYPE_PRECISION (argtype
);
362 resprec
= TYPE_PRECISION (restype
);
364 /* Depending on the type of the result, choose the long int intrinsic
365 (lround family) or long long intrinsic (llround). We might also
366 need to convert the result afterwards. */
367 if (resprec
<= LONG_TYPE_SIZE
)
369 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
374 /* Now, depending on the argument type, we choose between intrinsics. */
376 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
378 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
380 return fold_convert (restype
, build_call_expr_loc (input_location
,
385 /* Convert a real to an integer using a specific rounding mode.
386 Ideally we would just build the corresponding GENERIC node,
387 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
390 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
391 enum rounding_mode op
)
396 return build_fixbound_expr (pblock
, arg
, type
, 0);
400 return build_fixbound_expr (pblock
, arg
, type
, 1);
404 return build_round_expr (arg
, type
);
408 return fold_build1 (FIX_TRUNC_EXPR
, type
, arg
);
417 /* Round a real value using the specified rounding mode.
418 We use a temporary integer of that same kind size as the result.
419 Values larger than those that can be represented by this kind are
420 unchanged, as they will not be accurate enough to represent the
422 huge = HUGE (KIND (a))
423 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
427 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
439 kind
= expr
->ts
.kind
;
440 nargs
= gfc_intrinsic_argument_list_length (expr
);
443 /* We have builtin functions for some cases. */
447 decl
= builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
451 decl
= builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
458 /* Evaluate the argument. */
459 gcc_assert (expr
->value
.function
.actual
->expr
);
460 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
462 /* Use a builtin function if one exists. */
463 if (decl
!= NULL_TREE
)
465 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
469 /* This code is probably redundant, but we'll keep it lying around just
471 type
= gfc_typenode_for_spec (&expr
->ts
);
472 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
474 /* Test if the value is too large to handle sensibly. */
475 gfc_set_model_kind (kind
);
477 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
478 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
479 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
480 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, arg
[0], tmp
);
482 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
483 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
484 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
[0], tmp
);
485 cond
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
486 itype
= gfc_get_int_type (kind
);
488 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
489 tmp
= convert (type
, tmp
);
490 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
, tmp
, arg
[0]);
495 /* Convert to an integer using the specified rounding mode. */
498 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
504 nargs
= gfc_intrinsic_argument_list_length (expr
);
505 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
507 /* Evaluate the argument, we process all arguments even though we only
508 use the first one for code generation purposes. */
509 type
= gfc_typenode_for_spec (&expr
->ts
);
510 gcc_assert (expr
->value
.function
.actual
->expr
);
511 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
513 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
515 /* Conversion to a different integer kind. */
516 se
->expr
= convert (type
, args
[0]);
520 /* Conversion from complex to non-complex involves taking the real
521 component of the value. */
522 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
523 && expr
->ts
.type
!= BT_COMPLEX
)
527 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
528 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
531 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
536 /* Get the imaginary component of a value. */
539 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
543 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
544 se
->expr
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
548 /* Get the complex conjugate of a value. */
551 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
555 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
556 se
->expr
= fold_build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
560 /* Initialize function decls for library functions. The external functions
561 are created as required. Builtin functions are added here. */
564 gfc_build_intrinsic_lib_fndecls (void)
566 gfc_intrinsic_map_t
*m
;
568 /* Add GCC builtin functions. */
569 for (m
= gfc_intrinsic_map
;
570 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
572 if (m
->float_built_in
!= END_BUILTINS
)
573 m
->real4_decl
= built_in_decls
[m
->float_built_in
];
574 if (m
->complex_float_built_in
!= END_BUILTINS
)
575 m
->complex4_decl
= built_in_decls
[m
->complex_float_built_in
];
576 if (m
->double_built_in
!= END_BUILTINS
)
577 m
->real8_decl
= built_in_decls
[m
->double_built_in
];
578 if (m
->complex_double_built_in
!= END_BUILTINS
)
579 m
->complex8_decl
= built_in_decls
[m
->complex_double_built_in
];
581 /* If real(kind=10) exists, it is always long double. */
582 if (m
->long_double_built_in
!= END_BUILTINS
)
583 m
->real10_decl
= built_in_decls
[m
->long_double_built_in
];
584 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
585 m
->complex10_decl
= built_in_decls
[m
->complex_long_double_built_in
];
587 /* For now, we assume that if real(kind=16) exists, it is long double.
588 Later, we will deal with __float128 and break this assumption. */
589 if (m
->long_double_built_in
!= END_BUILTINS
)
590 m
->real16_decl
= built_in_decls
[m
->long_double_built_in
];
591 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
592 m
->complex16_decl
= built_in_decls
[m
->complex_long_double_built_in
];
597 /* Create a fndecl for a simple intrinsic library function. */
600 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
605 gfc_actual_arglist
*actual
;
608 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
611 if (ts
->type
== BT_REAL
)
616 pdecl
= &m
->real4_decl
;
619 pdecl
= &m
->real8_decl
;
622 pdecl
= &m
->real10_decl
;
625 pdecl
= &m
->real16_decl
;
631 else if (ts
->type
== BT_COMPLEX
)
633 gcc_assert (m
->complex_available
);
638 pdecl
= &m
->complex4_decl
;
641 pdecl
= &m
->complex8_decl
;
644 pdecl
= &m
->complex10_decl
;
647 pdecl
= &m
->complex16_decl
;
661 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
662 if (gfc_real_kinds
[n
].c_float
)
663 snprintf (name
, sizeof (name
), "%s%s%s",
664 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
665 else if (gfc_real_kinds
[n
].c_double
)
666 snprintf (name
, sizeof (name
), "%s%s",
667 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
668 else if (gfc_real_kinds
[n
].c_long_double
)
669 snprintf (name
, sizeof (name
), "%s%s%s",
670 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
676 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
677 ts
->type
== BT_COMPLEX
? 'c' : 'r',
681 argtypes
= NULL_TREE
;
682 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
684 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
685 argtypes
= gfc_chainon_list (argtypes
, type
);
687 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
688 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
689 fndecl
= build_decl (input_location
,
690 FUNCTION_DECL
, get_identifier (name
), type
);
692 /* Mark the decl as external. */
693 DECL_EXTERNAL (fndecl
) = 1;
694 TREE_PUBLIC (fndecl
) = 1;
696 /* Mark it __attribute__((const)), if possible. */
697 TREE_READONLY (fndecl
) = m
->is_constant
;
699 rest_of_decl_compilation (fndecl
, 1, 0);
706 /* Convert an intrinsic function into an external or builtin call. */
709 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
711 gfc_intrinsic_map_t
*m
;
715 unsigned int num_args
;
718 id
= expr
->value
.function
.isym
->id
;
719 /* Find the entry for this function. */
720 for (m
= gfc_intrinsic_map
;
721 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
727 if (m
->id
== GFC_ISYM_NONE
)
729 internal_error ("Intrinsic function %s(%d) not recognized",
730 expr
->value
.function
.name
, id
);
733 /* Get the decl and generate the call. */
734 num_args
= gfc_intrinsic_argument_list_length (expr
);
735 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
737 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
738 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
739 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
741 fndecl
= build_addr (fndecl
, current_function_decl
);
742 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
746 /* If bounds-checking is enabled, create code to verify at runtime that the
747 string lengths for both expressions are the same (needed for e.g. MERGE).
748 If bounds-checking is not enabled, does nothing. */
751 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
752 tree a
, tree b
, stmtblock_t
* target
)
757 /* If bounds-checking is disabled, do nothing. */
758 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
761 /* Compare the two string lengths. */
762 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, a
, b
);
764 /* Output the runtime-check. */
765 name
= gfc_build_cstring_const (intr_name
);
766 name
= gfc_build_addr_expr (pchar_type_node
, name
);
767 gfc_trans_runtime_check (true, false, cond
, target
, where
,
768 "Unequal character lengths (%ld/%ld) in %s",
769 fold_convert (long_integer_type_node
, a
),
770 fold_convert (long_integer_type_node
, b
), name
);
774 /* The EXPONENT(s) intrinsic function is translated into
781 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
783 tree arg
, type
, res
, tmp
, frexp
;
785 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
,
786 expr
->value
.function
.actual
->expr
->ts
.kind
);
788 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
790 res
= gfc_create_var (integer_type_node
, NULL
);
791 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
792 gfc_build_addr_expr (NULL_TREE
, res
));
793 gfc_add_expr_to_block (&se
->pre
, tmp
);
795 type
= gfc_typenode_for_spec (&expr
->ts
);
796 se
->expr
= fold_convert (type
, res
);
799 /* Evaluate a single upper or lower bound. */
800 /* TODO: bound intrinsic generates way too much unnecessary code. */
803 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
805 gfc_actual_arglist
*arg
;
806 gfc_actual_arglist
*arg2
;
811 tree cond
, cond1
, cond3
, cond4
, size
;
818 arg
= expr
->value
.function
.actual
;
823 /* Create an implicit second parameter from the loop variable. */
824 gcc_assert (!arg2
->expr
);
825 gcc_assert (se
->loop
->dimen
== 1);
826 gcc_assert (se
->ss
->expr
== expr
);
827 gfc_advance_se_ss_chain (se
);
828 bound
= se
->loop
->loopvar
[0];
829 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
834 /* use the passed argument. */
835 gcc_assert (arg
->next
->expr
);
836 gfc_init_se (&argse
, NULL
);
837 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
838 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
840 /* Convert from one based to zero based. */
841 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
845 /* TODO: don't re-evaluate the descriptor on each iteration. */
846 /* Get a descriptor for the first parameter. */
847 ss
= gfc_walk_expr (arg
->expr
);
848 gcc_assert (ss
!= gfc_ss_terminator
);
849 gfc_init_se (&argse
, NULL
);
850 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
851 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
852 gfc_add_block_to_block (&se
->post
, &argse
.post
);
856 if (INTEGER_CST_P (bound
))
860 hi
= TREE_INT_CST_HIGH (bound
);
861 low
= TREE_INT_CST_LOW (bound
);
862 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
863 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
864 "dimension index", upper
? "UBOUND" : "LBOUND",
869 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
871 bound
= gfc_evaluate_now (bound
, &se
->pre
);
872 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
873 bound
, build_int_cst (TREE_TYPE (bound
), 0));
874 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
875 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
876 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
877 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
882 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
883 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
885 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
887 /* 13.14.53: Result value for LBOUND
889 Case (i): For an array section or for an array expression other than a
890 whole array or array structure component, LBOUND(ARRAY, DIM)
891 has the value 1. For a whole array or array structure
892 component, LBOUND(ARRAY, DIM) has the value:
893 (a) equal to the lower bound for subscript DIM of ARRAY if
894 dimension DIM of ARRAY does not have extent zero
895 or if ARRAY is an assumed-size array of rank DIM,
898 13.14.113: Result value for UBOUND
900 Case (i): For an array section or for an array expression other than a
901 whole array or array structure component, UBOUND(ARRAY, DIM)
902 has the value equal to the number of elements in the given
903 dimension; otherwise, it has a value equal to the upper bound
904 for subscript DIM of ARRAY if dimension DIM of ARRAY does
905 not have size zero and has value zero if dimension DIM has
910 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
912 cond1
= fold_build2 (GE_EXPR
, boolean_type_node
, ubound
, lbound
);
914 cond3
= fold_build2 (GE_EXPR
, boolean_type_node
, stride
,
915 gfc_index_zero_node
);
916 cond3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond3
, cond1
);
918 cond4
= fold_build2 (LT_EXPR
, boolean_type_node
, stride
,
919 gfc_index_zero_node
);
924 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
926 cond5
= fold_build2 (EQ_EXPR
, boolean_type_node
, gfc_index_one_node
, lbound
);
927 cond5
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond4
, cond5
);
929 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond5
);
931 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
932 ubound
, gfc_index_zero_node
);
936 if (as
->type
== AS_ASSUMED_SIZE
)
937 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, bound
,
938 build_int_cst (TREE_TYPE (bound
),
939 arg
->expr
->rank
- 1));
941 cond
= boolean_false_node
;
943 cond1
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
944 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond1
);
946 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
947 lbound
, gfc_index_one_node
);
954 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
955 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
957 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
958 gfc_index_zero_node
);
961 se
->expr
= gfc_index_one_node
;
964 type
= gfc_typenode_for_spec (&expr
->ts
);
965 se
->expr
= convert (type
, se
->expr
);
970 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
974 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
976 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
980 se
->expr
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg
), arg
);
984 cabs
= builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
985 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
994 /* Create a complex value from one or two real components. */
997 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1003 unsigned int num_args
;
1005 num_args
= gfc_intrinsic_argument_list_length (expr
);
1006 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1008 type
= gfc_typenode_for_spec (&expr
->ts
);
1009 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1010 real
= convert (TREE_TYPE (type
), args
[0]);
1012 imag
= convert (TREE_TYPE (type
), args
[1]);
1013 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1015 imag
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (args
[0])),
1017 imag
= convert (TREE_TYPE (type
), imag
);
1020 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1022 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
1025 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1026 MODULO(A, P) = A - FLOOR (A / P) * P */
1027 /* TODO: MOD(x, 0) */
1030 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1042 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1044 switch (expr
->ts
.type
)
1047 /* Integer case is easy, we've got a builtin op. */
1048 type
= TREE_TYPE (args
[0]);
1051 se
->expr
= fold_build2 (FLOOR_MOD_EXPR
, type
, args
[0], args
[1]);
1053 se
->expr
= fold_build2 (TRUNC_MOD_EXPR
, type
, args
[0], args
[1]);
1058 /* Check if we have a builtin fmod. */
1059 fmod
= builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1061 /* Use it if it exists. */
1062 if (fmod
!= NULL_TREE
)
1064 tmp
= build_addr (fmod
, current_function_decl
);
1065 se
->expr
= build_call_array_loc (input_location
,
1066 TREE_TYPE (TREE_TYPE (fmod
)),
1072 type
= TREE_TYPE (args
[0]);
1074 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1075 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1078 modulo = arg - floor (arg/arg2) * arg2, so
1079 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1081 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1082 thereby avoiding another division and retaining the accuracy
1083 of the builtin function. */
1084 if (fmod
!= NULL_TREE
&& modulo
)
1086 tree zero
= gfc_build_const (type
, integer_zero_node
);
1087 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1088 test
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[0], zero
);
1089 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[1], zero
);
1090 test2
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
1091 test
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, zero
);
1092 test
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1093 test
= gfc_evaluate_now (test
, &se
->pre
);
1094 se
->expr
= fold_build3 (COND_EXPR
, type
, test
,
1095 fold_build2 (PLUS_EXPR
, type
, tmp
, args
[1]),
1100 /* If we do not have a built_in fmod, the calculation is going to
1101 have to be done longhand. */
1102 tmp
= fold_build2 (RDIV_EXPR
, type
, args
[0], args
[1]);
1104 /* Test if the value is too large to handle sensibly. */
1105 gfc_set_model_kind (expr
->ts
.kind
);
1107 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1108 ikind
= expr
->ts
.kind
;
1111 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1112 ikind
= gfc_max_integer_kind
;
1114 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1115 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1116 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
1118 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1119 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1120 test
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
1121 test2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1123 itype
= gfc_get_int_type (ikind
);
1125 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1127 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1128 tmp
= convert (type
, tmp
);
1129 tmp
= fold_build3 (COND_EXPR
, type
, test2
, tmp
, args
[0]);
1130 tmp
= fold_build2 (MULT_EXPR
, type
, tmp
, args
[1]);
1131 se
->expr
= fold_build2 (MINUS_EXPR
, type
, args
[0], tmp
);
1140 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1143 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1151 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1152 type
= TREE_TYPE (args
[0]);
1154 val
= fold_build2 (MINUS_EXPR
, type
, args
[0], args
[1]);
1155 val
= gfc_evaluate_now (val
, &se
->pre
);
1157 zero
= gfc_build_const (type
, integer_zero_node
);
1158 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
1159 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, zero
, val
);
1163 /* SIGN(A, B) is absolute value of A times sign of B.
1164 The real value versions use library functions to ensure the correct
1165 handling of negative zero. Integer case implemented as:
1166 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1170 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1176 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1177 if (expr
->ts
.type
== BT_REAL
)
1181 tmp
= builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1182 abs
= builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1184 /* We explicitly have to ignore the minus sign. We do so by using
1185 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1186 if (!gfc_option
.flag_sign_zero
1187 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1190 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1191 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
1192 se
->expr
= fold_build3 (COND_EXPR
, TREE_TYPE (args
[0]), cond
,
1193 build_call_expr (abs
, 1, args
[0]),
1194 build_call_expr (tmp
, 2, args
[0], args
[1]));
1197 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1202 /* Having excluded floating point types, we know we are now dealing
1203 with signed integer types. */
1204 type
= TREE_TYPE (args
[0]);
1206 /* Args[0] is used multiple times below. */
1207 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1209 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1210 the signs of A and B are the same, and of all ones if they differ. */
1211 tmp
= fold_build2 (BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1212 tmp
= fold_build2 (RSHIFT_EXPR
, type
, tmp
,
1213 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1214 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1216 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1217 is all ones (i.e. -1). */
1218 se
->expr
= fold_build2 (BIT_XOR_EXPR
, type
,
1219 fold_build2 (PLUS_EXPR
, type
, args
[0], tmp
),
1224 /* Test for the presence of an optional argument. */
1227 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1231 arg
= expr
->value
.function
.actual
->expr
;
1232 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1233 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1234 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1238 /* Calculate the double precision product of two single precision values. */
1241 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1246 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1248 /* Convert the args to double precision before multiplying. */
1249 type
= gfc_typenode_for_spec (&expr
->ts
);
1250 args
[0] = convert (type
, args
[0]);
1251 args
[1] = convert (type
, args
[1]);
1252 se
->expr
= fold_build2 (MULT_EXPR
, type
, args
[0], args
[1]);
1256 /* Return a length one character string containing an ascii character. */
1259 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1264 unsigned int num_args
;
1266 num_args
= gfc_intrinsic_argument_list_length (expr
);
1267 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
1269 type
= gfc_get_char_type (expr
->ts
.kind
);
1270 var
= gfc_create_var (type
, "char");
1272 arg
[0] = fold_build1 (NOP_EXPR
, type
, arg
[0]);
1273 gfc_add_modify (&se
->pre
, var
, arg
[0]);
1274 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1275 se
->string_length
= integer_one_node
;
1280 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1288 unsigned int num_args
;
1290 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1291 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1293 var
= gfc_create_var (pchar_type_node
, "pstr");
1294 len
= gfc_create_var (gfc_get_int_type (8), "len");
1296 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1297 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1298 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1300 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
1301 tmp
= build_call_array_loc (input_location
,
1302 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1303 fndecl
, num_args
, args
);
1304 gfc_add_expr_to_block (&se
->pre
, tmp
);
1306 /* Free the temporary afterwards, if necessary. */
1307 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1308 len
, build_int_cst (TREE_TYPE (len
), 0));
1309 tmp
= gfc_call_free (var
);
1310 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1311 gfc_add_expr_to_block (&se
->post
, tmp
);
1314 se
->string_length
= len
;
1319 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1327 unsigned int num_args
;
1329 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1330 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1332 var
= gfc_create_var (pchar_type_node
, "pstr");
1333 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1335 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1336 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1337 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1339 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1340 tmp
= build_call_array_loc (input_location
,
1341 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1342 fndecl
, num_args
, args
);
1343 gfc_add_expr_to_block (&se
->pre
, tmp
);
1345 /* Free the temporary afterwards, if necessary. */
1346 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1347 len
, build_int_cst (TREE_TYPE (len
), 0));
1348 tmp
= gfc_call_free (var
);
1349 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1350 gfc_add_expr_to_block (&se
->post
, tmp
);
1353 se
->string_length
= len
;
1357 /* Return a character string containing the tty name. */
1360 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1368 unsigned int num_args
;
1370 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1371 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1373 var
= gfc_create_var (pchar_type_node
, "pstr");
1374 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1376 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1377 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1378 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1380 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1381 tmp
= build_call_array_loc (input_location
,
1382 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1383 fndecl
, num_args
, args
);
1384 gfc_add_expr_to_block (&se
->pre
, tmp
);
1386 /* Free the temporary afterwards, if necessary. */
1387 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1388 len
, build_int_cst (TREE_TYPE (len
), 0));
1389 tmp
= gfc_call_free (var
);
1390 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1391 gfc_add_expr_to_block (&se
->post
, tmp
);
1394 se
->string_length
= len
;
1398 /* Get the minimum/maximum value of all the parameters.
1399 minmax (a1, a2, a3, ...)
1402 if (a2 .op. mvar || isnan(mvar))
1404 if (a3 .op. mvar || isnan(mvar))
1411 /* TODO: Mismatching types can occur when specific names are used.
1412 These should be handled during resolution. */
1414 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1422 gfc_actual_arglist
*argexpr
;
1423 unsigned int i
, nargs
;
1425 nargs
= gfc_intrinsic_argument_list_length (expr
);
1426 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
1428 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1429 type
= gfc_typenode_for_spec (&expr
->ts
);
1431 argexpr
= expr
->value
.function
.actual
;
1432 if (TREE_TYPE (args
[0]) != type
)
1433 args
[0] = convert (type
, args
[0]);
1434 /* Only evaluate the argument once. */
1435 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
1436 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1438 mvar
= gfc_create_var (type
, "M");
1439 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
1440 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1446 /* Handle absent optional arguments by ignoring the comparison. */
1447 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1448 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1449 && TREE_CODE (val
) == INDIRECT_REF
)
1450 cond
= fold_build2_loc (input_location
,
1451 NE_EXPR
, boolean_type_node
,
1452 TREE_OPERAND (val
, 0),
1453 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1458 /* Only evaluate the argument once. */
1459 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1460 val
= gfc_evaluate_now (val
, &se
->pre
);
1463 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1465 tmp
= fold_build2 (op
, boolean_type_node
, convert (type
, val
), mvar
);
1467 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1468 __builtin_isnan might be made dependent on that module being loaded,
1469 to help performance of programs that don't rely on IEEE semantics. */
1470 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
1472 isnan
= build_call_expr_loc (input_location
,
1473 built_in_decls
[BUILT_IN_ISNAN
], 1, mvar
);
1474 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
,
1475 fold_convert (boolean_type_node
, isnan
));
1477 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
1478 build_empty_stmt (input_location
));
1480 if (cond
!= NULL_TREE
)
1481 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1482 build_empty_stmt (input_location
));
1484 gfc_add_expr_to_block (&se
->pre
, tmp
);
1485 argexpr
= argexpr
->next
;
1491 /* Generate library calls for MIN and MAX intrinsics for character
1494 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
1497 tree var
, len
, fndecl
, tmp
, cond
, function
;
1500 nargs
= gfc_intrinsic_argument_list_length (expr
);
1501 args
= (tree
*) alloca (sizeof (tree
) * (nargs
+ 4));
1502 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
1504 /* Create the result variables. */
1505 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1506 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
1507 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
1508 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
1509 args
[2] = build_int_cst (NULL_TREE
, op
);
1510 args
[3] = build_int_cst (NULL_TREE
, nargs
/ 2);
1512 if (expr
->ts
.kind
== 1)
1513 function
= gfor_fndecl_string_minmax
;
1514 else if (expr
->ts
.kind
== 4)
1515 function
= gfor_fndecl_string_minmax_char4
;
1519 /* Make the function call. */
1520 fndecl
= build_addr (function
, current_function_decl
);
1521 tmp
= build_call_array_loc (input_location
,
1522 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
1524 gfc_add_expr_to_block (&se
->pre
, tmp
);
1526 /* Free the temporary afterwards, if necessary. */
1527 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1528 len
, build_int_cst (TREE_TYPE (len
), 0));
1529 tmp
= gfc_call_free (var
);
1530 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1531 gfc_add_expr_to_block (&se
->post
, tmp
);
1534 se
->string_length
= len
;
1538 /* Create a symbol node for this intrinsic. The symbol from the frontend
1539 has the generic name. */
1542 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1546 /* TODO: Add symbols for intrinsic function to the global namespace. */
1547 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1548 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1551 sym
->attr
.external
= 1;
1552 sym
->attr
.function
= 1;
1553 sym
->attr
.always_explicit
= 1;
1554 sym
->attr
.proc
= PROC_INTRINSIC
;
1555 sym
->attr
.flavor
= FL_PROCEDURE
;
1559 sym
->attr
.dimension
= 1;
1560 sym
->as
= gfc_get_array_spec ();
1561 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1562 sym
->as
->rank
= expr
->rank
;
1565 /* TODO: proper argument lists for external intrinsics. */
1569 /* Generate a call to an external intrinsic function. */
1571 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1574 VEC(tree
,gc
) *append_args
;
1576 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1579 gcc_assert (expr
->rank
> 0);
1581 gcc_assert (expr
->rank
== 0);
1583 sym
= gfc_get_symbol_for_expr (expr
);
1585 /* Calls to libgfortran_matmul need to be appended special arguments,
1586 to be able to call the BLAS ?gemm functions if required and possible. */
1588 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1589 && sym
->ts
.type
!= BT_LOGICAL
)
1591 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1593 if (gfc_option
.flag_external_blas
1594 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1595 && (sym
->ts
.kind
== gfc_default_real_kind
1596 || sym
->ts
.kind
== gfc_default_double_kind
))
1600 if (sym
->ts
.type
== BT_REAL
)
1602 if (sym
->ts
.kind
== gfc_default_real_kind
)
1603 gemm_fndecl
= gfor_fndecl_sgemm
;
1605 gemm_fndecl
= gfor_fndecl_dgemm
;
1609 if (sym
->ts
.kind
== gfc_default_real_kind
)
1610 gemm_fndecl
= gfor_fndecl_cgemm
;
1612 gemm_fndecl
= gfor_fndecl_zgemm
;
1615 append_args
= VEC_alloc (tree
, gc
, 3);
1616 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 1));
1617 VEC_quick_push (tree
, append_args
,
1618 build_int_cst (cint
, gfc_option
.blas_matmul_limit
));
1619 VEC_quick_push (tree
, append_args
,
1620 gfc_build_addr_expr (NULL_TREE
, gemm_fndecl
));
1624 append_args
= VEC_alloc (tree
, gc
, 3);
1625 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
1626 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
1627 VEC_quick_push (tree
, append_args
, null_pointer_node
);
1631 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
1636 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1656 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1665 gfc_actual_arglist
*actual
;
1672 gfc_conv_intrinsic_funcall (se
, expr
);
1676 actual
= expr
->value
.function
.actual
;
1677 type
= gfc_typenode_for_spec (&expr
->ts
);
1678 /* Initialize the result. */
1679 resvar
= gfc_create_var (type
, "test");
1681 tmp
= convert (type
, boolean_true_node
);
1683 tmp
= convert (type
, boolean_false_node
);
1684 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1686 /* Walk the arguments. */
1687 arrayss
= gfc_walk_expr (actual
->expr
);
1688 gcc_assert (arrayss
!= gfc_ss_terminator
);
1690 /* Initialize the scalarizer. */
1691 gfc_init_loopinfo (&loop
);
1692 exit_label
= gfc_build_label_decl (NULL_TREE
);
1693 TREE_USED (exit_label
) = 1;
1694 gfc_add_ss_to_loop (&loop
, arrayss
);
1696 /* Initialize the loop. */
1697 gfc_conv_ss_startstride (&loop
);
1698 gfc_conv_loop_setup (&loop
, &expr
->where
);
1700 gfc_mark_ss_chain_used (arrayss
, 1);
1701 /* Generate the loop body. */
1702 gfc_start_scalarized_body (&loop
, &body
);
1704 /* If the condition matches then set the return value. */
1705 gfc_start_block (&block
);
1707 tmp
= convert (type
, boolean_false_node
);
1709 tmp
= convert (type
, boolean_true_node
);
1710 gfc_add_modify (&block
, resvar
, tmp
);
1712 /* And break out of the loop. */
1713 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1714 gfc_add_expr_to_block (&block
, tmp
);
1716 found
= gfc_finish_block (&block
);
1718 /* Check this element. */
1719 gfc_init_se (&arrayse
, NULL
);
1720 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1721 arrayse
.ss
= arrayss
;
1722 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1724 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1725 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1726 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1727 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
1728 gfc_add_expr_to_block (&body
, tmp
);
1729 gfc_add_block_to_block (&body
, &arrayse
.post
);
1731 gfc_trans_scalarizing_loops (&loop
, &body
);
1733 /* Add the exit label. */
1734 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1735 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1737 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1738 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1739 gfc_cleanup_loop (&loop
);
1744 /* COUNT(A) = Number of true elements in A. */
1746 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1753 gfc_actual_arglist
*actual
;
1759 gfc_conv_intrinsic_funcall (se
, expr
);
1763 actual
= expr
->value
.function
.actual
;
1765 type
= gfc_typenode_for_spec (&expr
->ts
);
1766 /* Initialize the result. */
1767 resvar
= gfc_create_var (type
, "count");
1768 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
1770 /* Walk the arguments. */
1771 arrayss
= gfc_walk_expr (actual
->expr
);
1772 gcc_assert (arrayss
!= gfc_ss_terminator
);
1774 /* Initialize the scalarizer. */
1775 gfc_init_loopinfo (&loop
);
1776 gfc_add_ss_to_loop (&loop
, arrayss
);
1778 /* Initialize the loop. */
1779 gfc_conv_ss_startstride (&loop
);
1780 gfc_conv_loop_setup (&loop
, &expr
->where
);
1782 gfc_mark_ss_chain_used (arrayss
, 1);
1783 /* Generate the loop body. */
1784 gfc_start_scalarized_body (&loop
, &body
);
1786 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (resvar
),
1787 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
1788 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1790 gfc_init_se (&arrayse
, NULL
);
1791 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1792 arrayse
.ss
= arrayss
;
1793 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1794 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
1795 build_empty_stmt (input_location
));
1797 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1798 gfc_add_expr_to_block (&body
, tmp
);
1799 gfc_add_block_to_block (&body
, &arrayse
.post
);
1801 gfc_trans_scalarizing_loops (&loop
, &body
);
1803 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1804 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1805 gfc_cleanup_loop (&loop
);
1810 /* Inline implementation of the sum and product intrinsics. */
1812 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1820 gfc_actual_arglist
*actual
;
1825 gfc_expr
*arrayexpr
;
1830 gfc_conv_intrinsic_funcall (se
, expr
);
1834 type
= gfc_typenode_for_spec (&expr
->ts
);
1835 /* Initialize the result. */
1836 resvar
= gfc_create_var (type
, "val");
1837 if (op
== PLUS_EXPR
)
1838 tmp
= gfc_build_const (type
, integer_zero_node
);
1840 tmp
= gfc_build_const (type
, integer_one_node
);
1842 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1844 /* Walk the arguments. */
1845 actual
= expr
->value
.function
.actual
;
1846 arrayexpr
= actual
->expr
;
1847 arrayss
= gfc_walk_expr (arrayexpr
);
1848 gcc_assert (arrayss
!= gfc_ss_terminator
);
1850 actual
= actual
->next
->next
;
1851 gcc_assert (actual
);
1852 maskexpr
= actual
->expr
;
1853 if (maskexpr
&& maskexpr
->rank
!= 0)
1855 maskss
= gfc_walk_expr (maskexpr
);
1856 gcc_assert (maskss
!= gfc_ss_terminator
);
1861 /* Initialize the scalarizer. */
1862 gfc_init_loopinfo (&loop
);
1863 gfc_add_ss_to_loop (&loop
, arrayss
);
1865 gfc_add_ss_to_loop (&loop
, maskss
);
1867 /* Initialize the loop. */
1868 gfc_conv_ss_startstride (&loop
);
1869 gfc_conv_loop_setup (&loop
, &expr
->where
);
1871 gfc_mark_ss_chain_used (arrayss
, 1);
1873 gfc_mark_ss_chain_used (maskss
, 1);
1874 /* Generate the loop body. */
1875 gfc_start_scalarized_body (&loop
, &body
);
1877 /* If we have a mask, only add this element if the mask is set. */
1880 gfc_init_se (&maskse
, NULL
);
1881 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1883 gfc_conv_expr_val (&maskse
, maskexpr
);
1884 gfc_add_block_to_block (&body
, &maskse
.pre
);
1886 gfc_start_block (&block
);
1889 gfc_init_block (&block
);
1891 /* Do the actual summation/product. */
1892 gfc_init_se (&arrayse
, NULL
);
1893 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1894 arrayse
.ss
= arrayss
;
1895 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1896 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1898 tmp
= fold_build2 (op
, type
, resvar
, arrayse
.expr
);
1899 gfc_add_modify (&block
, resvar
, tmp
);
1900 gfc_add_block_to_block (&block
, &arrayse
.post
);
1904 /* We enclose the above in if (mask) {...} . */
1905 tmp
= gfc_finish_block (&block
);
1907 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
1908 build_empty_stmt (input_location
));
1911 tmp
= gfc_finish_block (&block
);
1912 gfc_add_expr_to_block (&body
, tmp
);
1914 gfc_trans_scalarizing_loops (&loop
, &body
);
1916 /* For a scalar mask, enclose the loop in an if statement. */
1917 if (maskexpr
&& maskss
== NULL
)
1919 gfc_init_se (&maskse
, NULL
);
1920 gfc_conv_expr_val (&maskse
, maskexpr
);
1921 gfc_init_block (&block
);
1922 gfc_add_block_to_block (&block
, &loop
.pre
);
1923 gfc_add_block_to_block (&block
, &loop
.post
);
1924 tmp
= gfc_finish_block (&block
);
1926 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
1927 build_empty_stmt (input_location
));
1928 gfc_add_expr_to_block (&block
, tmp
);
1929 gfc_add_block_to_block (&se
->pre
, &block
);
1933 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1934 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1937 gfc_cleanup_loop (&loop
);
1943 /* Inline implementation of the dot_product intrinsic. This function
1944 is based on gfc_conv_intrinsic_arith (the previous function). */
1946 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1954 gfc_actual_arglist
*actual
;
1955 gfc_ss
*arrayss1
, *arrayss2
;
1956 gfc_se arrayse1
, arrayse2
;
1957 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1959 type
= gfc_typenode_for_spec (&expr
->ts
);
1961 /* Initialize the result. */
1962 resvar
= gfc_create_var (type
, "val");
1963 if (expr
->ts
.type
== BT_LOGICAL
)
1964 tmp
= build_int_cst (type
, 0);
1966 tmp
= gfc_build_const (type
, integer_zero_node
);
1968 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1970 /* Walk argument #1. */
1971 actual
= expr
->value
.function
.actual
;
1972 arrayexpr1
= actual
->expr
;
1973 arrayss1
= gfc_walk_expr (arrayexpr1
);
1974 gcc_assert (arrayss1
!= gfc_ss_terminator
);
1976 /* Walk argument #2. */
1977 actual
= actual
->next
;
1978 arrayexpr2
= actual
->expr
;
1979 arrayss2
= gfc_walk_expr (arrayexpr2
);
1980 gcc_assert (arrayss2
!= gfc_ss_terminator
);
1982 /* Initialize the scalarizer. */
1983 gfc_init_loopinfo (&loop
);
1984 gfc_add_ss_to_loop (&loop
, arrayss1
);
1985 gfc_add_ss_to_loop (&loop
, arrayss2
);
1987 /* Initialize the loop. */
1988 gfc_conv_ss_startstride (&loop
);
1989 gfc_conv_loop_setup (&loop
, &expr
->where
);
1991 gfc_mark_ss_chain_used (arrayss1
, 1);
1992 gfc_mark_ss_chain_used (arrayss2
, 1);
1994 /* Generate the loop body. */
1995 gfc_start_scalarized_body (&loop
, &body
);
1996 gfc_init_block (&block
);
1998 /* Make the tree expression for [conjg(]array1[)]. */
1999 gfc_init_se (&arrayse1
, NULL
);
2000 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2001 arrayse1
.ss
= arrayss1
;
2002 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2003 if (expr
->ts
.type
== BT_COMPLEX
)
2004 arrayse1
.expr
= fold_build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
2005 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2007 /* Make the tree expression for array2. */
2008 gfc_init_se (&arrayse2
, NULL
);
2009 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2010 arrayse2
.ss
= arrayss2
;
2011 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2012 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2014 /* Do the actual product and sum. */
2015 if (expr
->ts
.type
== BT_LOGICAL
)
2017 tmp
= fold_build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2018 tmp
= fold_build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2022 tmp
= fold_build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2023 tmp
= fold_build2 (PLUS_EXPR
, type
, resvar
, tmp
);
2025 gfc_add_modify (&block
, resvar
, tmp
);
2027 /* Finish up the loop block and the loop. */
2028 tmp
= gfc_finish_block (&block
);
2029 gfc_add_expr_to_block (&body
, tmp
);
2031 gfc_trans_scalarizing_loops (&loop
, &body
);
2032 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2033 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2034 gfc_cleanup_loop (&loop
);
2040 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2041 we need to handle. For performance reasons we sometimes create two
2042 loops instead of one, where the second one is much simpler.
2043 Examples for minloc intrinsic:
2044 1) Result is an array, a call is generated
2045 2) Array mask is used and NaNs need to be supported:
2051 if (pos == 0) pos = S + (1 - from);
2052 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2059 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2063 3) NaNs need to be supported, but it is known at compile time or cheaply
2064 at runtime whether array is nonempty or not:
2069 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2072 if (from <= to) pos = 1;
2076 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2080 4) NaNs aren't supported, array mask is used:
2081 limit = infinities_supported ? Infinity : huge (limit);
2085 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2091 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2095 5) Same without array mask:
2096 limit = infinities_supported ? Infinity : huge (limit);
2097 pos = (from <= to) ? 1 : 0;
2100 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2103 For 3) and 5), if mask is scalar, this all goes into a conditional,
2104 setting pos = 0; in the else branch. */
2107 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2111 stmtblock_t ifblock
;
2112 stmtblock_t elseblock
;
2123 gfc_actual_arglist
*actual
;
2128 gfc_expr
*arrayexpr
;
2135 gfc_conv_intrinsic_funcall (se
, expr
);
2139 /* Initialize the result. */
2140 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2141 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2142 type
= gfc_typenode_for_spec (&expr
->ts
);
2144 /* Walk the arguments. */
2145 actual
= expr
->value
.function
.actual
;
2146 arrayexpr
= actual
->expr
;
2147 arrayss
= gfc_walk_expr (arrayexpr
);
2148 gcc_assert (arrayss
!= gfc_ss_terminator
);
2150 actual
= actual
->next
->next
;
2151 gcc_assert (actual
);
2152 maskexpr
= actual
->expr
;
2154 if (maskexpr
&& maskexpr
->rank
!= 0)
2156 maskss
= gfc_walk_expr (maskexpr
);
2157 gcc_assert (maskss
!= gfc_ss_terminator
);
2162 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
2164 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
2166 nonempty
= fold_build2 (GT_EXPR
, boolean_type_node
, nonempty
,
2167 gfc_index_zero_node
);
2172 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2173 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2174 switch (arrayexpr
->ts
.type
)
2177 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2179 REAL_VALUE_TYPE real
;
2181 tmp
= build_real (TREE_TYPE (limit
), real
);
2184 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
2185 arrayexpr
->ts
.kind
, 0);
2189 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2190 arrayexpr
->ts
.kind
);
2197 /* We start with the most negative possible value for MAXLOC, and the most
2198 positive possible value for MINLOC. The most negative possible value is
2199 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2200 possible value is HUGE in both cases. */
2202 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2203 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2204 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2205 build_int_cst (type
, 1));
2207 gfc_add_modify (&se
->pre
, limit
, tmp
);
2209 /* Initialize the scalarizer. */
2210 gfc_init_loopinfo (&loop
);
2211 gfc_add_ss_to_loop (&loop
, arrayss
);
2213 gfc_add_ss_to_loop (&loop
, maskss
);
2215 /* Initialize the loop. */
2216 gfc_conv_ss_startstride (&loop
);
2217 gfc_conv_loop_setup (&loop
, &expr
->where
);
2219 gcc_assert (loop
.dimen
== 1);
2220 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
2221 nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
, loop
.from
[0],
2226 /* Initialize the position to zero, following Fortran 2003. We are free
2227 to do this because Fortran 95 allows the result of an entirely false
2228 mask to be processor dependent. If we know at compile time the array
2229 is non-empty and no MASK is used, we can initialize to 1 to simplify
2231 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
2232 gfc_add_modify (&loop
.pre
, pos
,
2233 fold_build3 (COND_EXPR
, gfc_array_index_type
,
2234 nonempty
, gfc_index_one_node
,
2235 gfc_index_zero_node
));
2238 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
2239 lab1
= gfc_build_label_decl (NULL_TREE
);
2240 TREE_USED (lab1
) = 1;
2241 lab2
= gfc_build_label_decl (NULL_TREE
);
2242 TREE_USED (lab2
) = 1;
2245 gfc_mark_ss_chain_used (arrayss
, 1);
2247 gfc_mark_ss_chain_used (maskss
, 1);
2248 /* Generate the loop body. */
2249 gfc_start_scalarized_body (&loop
, &body
);
2251 /* If we have a mask, only check this element if the mask is set. */
2254 gfc_init_se (&maskse
, NULL
);
2255 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2257 gfc_conv_expr_val (&maskse
, maskexpr
);
2258 gfc_add_block_to_block (&body
, &maskse
.pre
);
2260 gfc_start_block (&block
);
2263 gfc_init_block (&block
);
2265 /* Compare with the current limit. */
2266 gfc_init_se (&arrayse
, NULL
);
2267 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2268 arrayse
.ss
= arrayss
;
2269 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2270 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2272 /* We do the following if this is a more extreme value. */
2273 gfc_start_block (&ifblock
);
2275 /* Assign the value to the limit... */
2276 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2278 /* Remember where we are. An offset must be added to the loop
2279 counter to obtain the required position. */
2281 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2282 gfc_index_one_node
, loop
.from
[0]);
2284 tmp
= gfc_index_one_node
;
2286 gfc_add_modify (&block
, offset
, tmp
);
2288 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
2290 stmtblock_t ifblock2
;
2293 gfc_start_block (&ifblock2
);
2294 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2295 loop
.loopvar
[0], offset
);
2296 gfc_add_modify (&ifblock2
, pos
, tmp
);
2297 ifbody2
= gfc_finish_block (&ifblock2
);
2298 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, pos
,
2299 gfc_index_zero_node
);
2300 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
2301 build_empty_stmt (input_location
));
2302 gfc_add_expr_to_block (&block
, tmp
);
2305 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2306 loop
.loopvar
[0], offset
);
2307 gfc_add_modify (&ifblock
, pos
, tmp
);
2310 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
2312 ifbody
= gfc_finish_block (&ifblock
);
2314 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
2317 cond
= fold_build2 (op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
2318 boolean_type_node
, arrayse
.expr
, limit
);
2320 cond
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2322 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
2323 build_empty_stmt (input_location
));
2325 gfc_add_expr_to_block (&block
, ifbody
);
2329 /* We enclose the above in if (mask) {...}. */
2330 tmp
= gfc_finish_block (&block
);
2332 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2333 build_empty_stmt (input_location
));
2336 tmp
= gfc_finish_block (&block
);
2337 gfc_add_expr_to_block (&body
, tmp
);
2341 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
2343 if (HONOR_NANS (DECL_MODE (limit
)))
2345 if (nonempty
!= NULL
)
2347 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
2348 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
2349 build_empty_stmt (input_location
));
2350 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
2354 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
2355 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
2356 gfc_start_block (&body
);
2358 /* If we have a mask, only check this element if the mask is set. */
2361 gfc_init_se (&maskse
, NULL
);
2362 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2364 gfc_conv_expr_val (&maskse
, maskexpr
);
2365 gfc_add_block_to_block (&body
, &maskse
.pre
);
2367 gfc_start_block (&block
);
2370 gfc_init_block (&block
);
2372 /* Compare with the current limit. */
2373 gfc_init_se (&arrayse
, NULL
);
2374 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2375 arrayse
.ss
= arrayss
;
2376 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2377 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2379 /* We do the following if this is a more extreme value. */
2380 gfc_start_block (&ifblock
);
2382 /* Assign the value to the limit... */
2383 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2385 /* Remember where we are. An offset must be added to the loop
2386 counter to obtain the required position. */
2388 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2389 gfc_index_one_node
, loop
.from
[0]);
2391 tmp
= gfc_index_one_node
;
2393 gfc_add_modify (&block
, offset
, tmp
);
2395 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2396 loop
.loopvar
[0], offset
);
2397 gfc_add_modify (&ifblock
, pos
, tmp
);
2399 ifbody
= gfc_finish_block (&ifblock
);
2401 cond
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2403 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
2404 build_empty_stmt (input_location
));
2405 gfc_add_expr_to_block (&block
, tmp
);
2409 /* We enclose the above in if (mask) {...}. */
2410 tmp
= gfc_finish_block (&block
);
2412 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2413 build_empty_stmt (input_location
));
2416 tmp
= gfc_finish_block (&block
);
2417 gfc_add_expr_to_block (&body
, tmp
);
2418 /* Avoid initializing loopvar[0] again, it should be left where
2419 it finished by the first loop. */
2420 loop
.from
[0] = loop
.loopvar
[0];
2423 gfc_trans_scalarizing_loops (&loop
, &body
);
2426 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
2428 /* For a scalar mask, enclose the loop in an if statement. */
2429 if (maskexpr
&& maskss
== NULL
)
2431 gfc_init_se (&maskse
, NULL
);
2432 gfc_conv_expr_val (&maskse
, maskexpr
);
2433 gfc_init_block (&block
);
2434 gfc_add_block_to_block (&block
, &loop
.pre
);
2435 gfc_add_block_to_block (&block
, &loop
.post
);
2436 tmp
= gfc_finish_block (&block
);
2438 /* For the else part of the scalar mask, just initialize
2439 the pos variable the same way as above. */
2441 gfc_init_block (&elseblock
);
2442 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
2443 elsetmp
= gfc_finish_block (&elseblock
);
2445 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2446 gfc_add_expr_to_block (&block
, tmp
);
2447 gfc_add_block_to_block (&se
->pre
, &block
);
2451 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2452 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2454 gfc_cleanup_loop (&loop
);
2456 se
->expr
= convert (type
, pos
);
2459 /* Emit code for minval or maxval intrinsic. There are many different cases
2460 we need to handle. For performance reasons we sometimes create two
2461 loops instead of one, where the second one is much simpler.
2462 Examples for minval intrinsic:
2463 1) Result is an array, a call is generated
2464 2) Array mask is used and NaNs need to be supported, rank 1:
2469 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2472 limit = nonempty ? NaN : huge (limit);
2474 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2475 3) NaNs need to be supported, but it is known at compile time or cheaply
2476 at runtime whether array is nonempty or not, rank 1:
2479 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2480 limit = (from <= to) ? NaN : huge (limit);
2482 while (S <= to) { limit = min (a[S], limit); S++; }
2483 4) Array mask is used and NaNs need to be supported, rank > 1:
2492 if (fast) limit = min (a[S1][S2], limit);
2495 if (a[S1][S2] <= limit) {
2506 limit = nonempty ? NaN : huge (limit);
2507 5) NaNs need to be supported, but it is known at compile time or cheaply
2508 at runtime whether array is nonempty or not, rank > 1:
2515 if (fast) limit = min (a[S1][S2], limit);
2517 if (a[S1][S2] <= limit) {
2527 limit = (nonempty_array) ? NaN : huge (limit);
2528 6) NaNs aren't supported, but infinities are. Array mask is used:
2533 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2536 limit = nonempty ? limit : huge (limit);
2537 7) Same without array mask:
2540 while (S <= to) { limit = min (a[S], limit); S++; }
2541 limit = (from <= to) ? limit : huge (limit);
2542 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2543 limit = huge (limit);
2545 while (S <= to) { limit = min (a[S], limit); S++); }
2547 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2548 with array mask instead).
2549 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2550 setting limit = huge (limit); in the else branch. */
2553 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2563 tree huge_cst
= NULL
, nan_cst
= NULL
;
2565 stmtblock_t block
, block2
;
2567 gfc_actual_arglist
*actual
;
2572 gfc_expr
*arrayexpr
;
2578 gfc_conv_intrinsic_funcall (se
, expr
);
2582 type
= gfc_typenode_for_spec (&expr
->ts
);
2583 /* Initialize the result. */
2584 limit
= gfc_create_var (type
, "limit");
2585 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2586 switch (expr
->ts
.type
)
2589 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
2591 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2593 REAL_VALUE_TYPE real
;
2595 tmp
= build_real (type
, real
);
2599 if (HONOR_NANS (DECL_MODE (limit
)))
2601 REAL_VALUE_TYPE real
;
2602 real_nan (&real
, "", 1, DECL_MODE (limit
));
2603 nan_cst
= build_real (type
, real
);
2608 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2615 /* We start with the most negative possible value for MAXVAL, and the most
2616 positive possible value for MINVAL. The most negative possible value is
2617 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2618 possible value is HUGE in both cases. */
2621 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2623 huge_cst
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (huge_cst
), huge_cst
);
2626 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2627 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
),
2628 tmp
, build_int_cst (type
, 1));
2630 gfc_add_modify (&se
->pre
, limit
, tmp
);
2632 /* Walk the arguments. */
2633 actual
= expr
->value
.function
.actual
;
2634 arrayexpr
= actual
->expr
;
2635 arrayss
= gfc_walk_expr (arrayexpr
);
2636 gcc_assert (arrayss
!= gfc_ss_terminator
);
2638 actual
= actual
->next
->next
;
2639 gcc_assert (actual
);
2640 maskexpr
= actual
->expr
;
2642 if (maskexpr
&& maskexpr
->rank
!= 0)
2644 maskss
= gfc_walk_expr (maskexpr
);
2645 gcc_assert (maskss
!= gfc_ss_terminator
);
2650 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
2652 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
2654 nonempty
= fold_build2 (GT_EXPR
, boolean_type_node
, nonempty
,
2655 gfc_index_zero_node
);
2660 /* Initialize the scalarizer. */
2661 gfc_init_loopinfo (&loop
);
2662 gfc_add_ss_to_loop (&loop
, arrayss
);
2664 gfc_add_ss_to_loop (&loop
, maskss
);
2666 /* Initialize the loop. */
2667 gfc_conv_ss_startstride (&loop
);
2668 gfc_conv_loop_setup (&loop
, &expr
->where
);
2670 if (nonempty
== NULL
&& maskss
== NULL
2671 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
2672 nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
, loop
.from
[0],
2674 nonempty_var
= NULL
;
2675 if (nonempty
== NULL
2676 && (HONOR_INFINITIES (DECL_MODE (limit
))
2677 || HONOR_NANS (DECL_MODE (limit
))))
2679 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
2680 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
2681 nonempty
= nonempty_var
;
2685 if (HONOR_NANS (DECL_MODE (limit
)))
2687 if (loop
.dimen
== 1)
2689 lab
= gfc_build_label_decl (NULL_TREE
);
2690 TREE_USED (lab
) = 1;
2694 fast
= gfc_create_var (boolean_type_node
, "fast");
2695 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
2699 gfc_mark_ss_chain_used (arrayss
, 1);
2701 gfc_mark_ss_chain_used (maskss
, 1);
2702 /* Generate the loop body. */
2703 gfc_start_scalarized_body (&loop
, &body
);
2705 /* If we have a mask, only add this element if the mask is set. */
2708 gfc_init_se (&maskse
, NULL
);
2709 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2711 gfc_conv_expr_val (&maskse
, maskexpr
);
2712 gfc_add_block_to_block (&body
, &maskse
.pre
);
2714 gfc_start_block (&block
);
2717 gfc_init_block (&block
);
2719 /* Compare with the current limit. */
2720 gfc_init_se (&arrayse
, NULL
);
2721 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2722 arrayse
.ss
= arrayss
;
2723 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2724 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2726 gfc_init_block (&block2
);
2729 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
2731 if (HONOR_NANS (DECL_MODE (limit
)))
2733 tmp
= fold_build2 (op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
2734 boolean_type_node
, arrayse
.expr
, limit
);
2736 ifbody
= build1_v (GOTO_EXPR
, lab
);
2739 stmtblock_t ifblock
;
2741 gfc_init_block (&ifblock
);
2742 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2743 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
2744 ifbody
= gfc_finish_block (&ifblock
);
2746 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
2747 build_empty_stmt (input_location
));
2748 gfc_add_expr_to_block (&block2
, tmp
);
2752 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2754 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
2756 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2757 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2758 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
2759 build_empty_stmt (input_location
));
2760 gfc_add_expr_to_block (&block2
, tmp
);
2764 tmp
= fold_build2 (op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
2765 type
, arrayse
.expr
, limit
);
2766 gfc_add_modify (&block2
, limit
, tmp
);
2772 tree elsebody
= gfc_finish_block (&block2
);
2774 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2776 if (HONOR_NANS (DECL_MODE (limit
))
2777 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
2779 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2780 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2781 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
2782 build_empty_stmt (input_location
));
2786 tmp
= fold_build2 (op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
2787 type
, arrayse
.expr
, limit
);
2788 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
2790 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
2791 gfc_add_expr_to_block (&block
, tmp
);
2794 gfc_add_block_to_block (&block
, &block2
);
2796 gfc_add_block_to_block (&block
, &arrayse
.post
);
2798 tmp
= gfc_finish_block (&block
);
2800 /* We enclose the above in if (mask) {...}. */
2801 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2802 build_empty_stmt (input_location
));
2803 gfc_add_expr_to_block (&body
, tmp
);
2807 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
2809 tmp
= fold_build3 (COND_EXPR
, type
, nonempty
, nan_cst
, huge_cst
);
2810 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
2811 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
2813 gfc_start_block (&body
);
2815 /* If we have a mask, only add this element if the mask is set. */
2818 gfc_init_se (&maskse
, NULL
);
2819 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2821 gfc_conv_expr_val (&maskse
, maskexpr
);
2822 gfc_add_block_to_block (&body
, &maskse
.pre
);
2824 gfc_start_block (&block
);
2827 gfc_init_block (&block
);
2829 /* Compare with the current limit. */
2830 gfc_init_se (&arrayse
, NULL
);
2831 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2832 arrayse
.ss
= arrayss
;
2833 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2834 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2836 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2838 if (HONOR_NANS (DECL_MODE (limit
))
2839 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
2841 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2842 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2843 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
2844 build_empty_stmt (input_location
));
2845 gfc_add_expr_to_block (&block
, tmp
);
2849 tmp
= fold_build2 (op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
2850 type
, arrayse
.expr
, limit
);
2851 gfc_add_modify (&block
, limit
, tmp
);
2854 gfc_add_block_to_block (&block
, &arrayse
.post
);
2856 tmp
= gfc_finish_block (&block
);
2858 /* We enclose the above in if (mask) {...}. */
2859 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2860 build_empty_stmt (input_location
));
2861 gfc_add_expr_to_block (&body
, tmp
);
2862 /* Avoid initializing loopvar[0] again, it should be left where
2863 it finished by the first loop. */
2864 loop
.from
[0] = loop
.loopvar
[0];
2866 gfc_trans_scalarizing_loops (&loop
, &body
);
2870 tmp
= fold_build3 (COND_EXPR
, type
, nonempty
, nan_cst
, huge_cst
);
2871 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
2872 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
2874 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2876 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
2878 tmp
= fold_build3 (COND_EXPR
, type
, nonempty
, limit
, huge_cst
);
2879 gfc_add_modify (&loop
.pre
, limit
, tmp
);
2882 /* For a scalar mask, enclose the loop in an if statement. */
2883 if (maskexpr
&& maskss
== NULL
)
2887 gfc_init_se (&maskse
, NULL
);
2888 gfc_conv_expr_val (&maskse
, maskexpr
);
2889 gfc_init_block (&block
);
2890 gfc_add_block_to_block (&block
, &loop
.pre
);
2891 gfc_add_block_to_block (&block
, &loop
.post
);
2892 tmp
= gfc_finish_block (&block
);
2894 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2895 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
2897 else_stmt
= build_empty_stmt (input_location
);
2898 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
2899 gfc_add_expr_to_block (&block
, tmp
);
2900 gfc_add_block_to_block (&se
->pre
, &block
);
2904 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2905 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2908 gfc_cleanup_loop (&loop
);
2913 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2915 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2921 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2922 type
= TREE_TYPE (args
[0]);
2924 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2925 tmp
= fold_build2 (BIT_AND_EXPR
, type
, args
[0], tmp
);
2926 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2927 build_int_cst (type
, 0));
2928 type
= gfc_typenode_for_spec (&expr
->ts
);
2929 se
->expr
= convert (type
, tmp
);
2932 /* Generate code to perform the specified operation. */
2934 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2938 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2939 se
->expr
= fold_build2 (op
, TREE_TYPE (args
[0]), args
[0], args
[1]);
2944 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2948 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2949 se
->expr
= fold_build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2952 /* Set or clear a single bit. */
2954 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2961 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2962 type
= TREE_TYPE (args
[0]);
2964 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2970 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2972 se
->expr
= fold_build2 (op
, type
, args
[0], tmp
);
2975 /* Extract a sequence of bits.
2976 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2978 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2985 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2986 type
= TREE_TYPE (args
[0]);
2988 mask
= build_int_cst (type
, -1);
2989 mask
= fold_build2 (LSHIFT_EXPR
, type
, mask
, args
[2]);
2990 mask
= fold_build1 (BIT_NOT_EXPR
, type
, mask
);
2992 tmp
= fold_build2 (RSHIFT_EXPR
, type
, args
[0], args
[1]);
2994 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2997 /* RSHIFT (I, SHIFT) = I >> SHIFT
2998 LSHIFT (I, SHIFT) = I << SHIFT */
3000 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
3004 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3006 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
3007 TREE_TYPE (args
[0]), args
[0], args
[1]);
3010 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3012 : ((shift >= 0) ? i << shift : i >> -shift)
3013 where all shifts are logical shifts. */
3015 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
3027 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3028 type
= TREE_TYPE (args
[0]);
3029 utype
= unsigned_type_for (type
);
3031 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (args
[1]), args
[1]);
3033 /* Left shift if positive. */
3034 lshift
= fold_build2 (LSHIFT_EXPR
, type
, args
[0], width
);
3036 /* Right shift if negative.
3037 We convert to an unsigned type because we want a logical shift.
3038 The standard doesn't define the case of shifting negative
3039 numbers, and we try to be compatible with other compilers, most
3040 notably g77, here. */
3041 rshift
= fold_convert (type
, fold_build2 (RSHIFT_EXPR
, utype
,
3042 convert (utype
, args
[0]), width
));
3044 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, args
[1],
3045 build_int_cst (TREE_TYPE (args
[1]), 0));
3046 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
3048 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3049 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3051 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
3052 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
3054 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
3055 build_int_cst (type
, 0), tmp
);
3059 /* Circular shift. AKA rotate or barrel shift. */
3062 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
3070 unsigned int num_args
;
3072 num_args
= gfc_intrinsic_argument_list_length (expr
);
3073 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
3075 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3079 /* Use a library function for the 3 parameter version. */
3080 tree int4type
= gfc_get_int_type (4);
3082 type
= TREE_TYPE (args
[0]);
3083 /* We convert the first argument to at least 4 bytes, and
3084 convert back afterwards. This removes the need for library
3085 functions for all argument sizes, and function will be
3086 aligned to at least 32 bits, so there's no loss. */
3087 if (expr
->ts
.kind
< 4)
3088 args
[0] = convert (int4type
, args
[0]);
3090 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3091 need loads of library functions. They cannot have values >
3092 BIT_SIZE (I) so the conversion is safe. */
3093 args
[1] = convert (int4type
, args
[1]);
3094 args
[2] = convert (int4type
, args
[2]);
3096 switch (expr
->ts
.kind
)
3101 tmp
= gfor_fndecl_math_ishftc4
;
3104 tmp
= gfor_fndecl_math_ishftc8
;
3107 tmp
= gfor_fndecl_math_ishftc16
;
3112 se
->expr
= build_call_expr_loc (input_location
,
3113 tmp
, 3, args
[0], args
[1], args
[2]);
3114 /* Convert the result back to the original type, if we extended
3115 the first argument's width above. */
3116 if (expr
->ts
.kind
< 4)
3117 se
->expr
= convert (type
, se
->expr
);
3121 type
= TREE_TYPE (args
[0]);
3123 /* Rotate left if positive. */
3124 lrot
= fold_build2 (LROTATE_EXPR
, type
, args
[0], args
[1]);
3126 /* Rotate right if negative. */
3127 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (args
[1]), args
[1]);
3128 rrot
= fold_build2 (RROTATE_EXPR
, type
, args
[0], tmp
);
3130 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
3131 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, args
[1], zero
);
3132 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
3134 /* Do nothing if shift == 0. */
3135 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
3136 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, args
[0], rrot
);
3139 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3140 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3142 The conditional expression is necessary because the result of LEADZ(0)
3143 is defined, but the result of __builtin_clz(0) is undefined for most
3146 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3147 difference in bit size between the argument of LEADZ and the C int. */
3150 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
3162 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3163 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3165 /* Which variant of __builtin_clz* should we call? */
3166 if (argsize
<= INT_TYPE_SIZE
)
3168 arg_type
= unsigned_type_node
;
3169 func
= built_in_decls
[BUILT_IN_CLZ
];
3171 else if (argsize
<= LONG_TYPE_SIZE
)
3173 arg_type
= long_unsigned_type_node
;
3174 func
= built_in_decls
[BUILT_IN_CLZL
];
3176 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3178 arg_type
= long_long_unsigned_type_node
;
3179 func
= built_in_decls
[BUILT_IN_CLZLL
];
3183 gcc_assert (argsize
== 128);
3184 arg_type
= gfc_build_uint_type (argsize
);
3185 func
= gfor_fndecl_clz128
;
3188 /* Convert the actual argument twice: first, to the unsigned type of the
3189 same size; then, to the proper argument type for the built-in
3190 function. But the return type is of the default INTEGER kind. */
3191 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3192 arg
= fold_convert (arg_type
, arg
);
3193 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3195 /* Compute LEADZ for the case i .ne. 0. */
3196 s
= TYPE_PRECISION (arg_type
) - argsize
;
3197 tmp
= fold_convert (result_type
, build_call_expr (func
, 1, arg
));
3198 leadz
= fold_build2 (MINUS_EXPR
, result_type
,
3199 tmp
, build_int_cst (result_type
, s
));
3201 /* Build BIT_SIZE. */
3202 bit_size
= build_int_cst (result_type
, argsize
);
3204 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3205 arg
, build_int_cst (arg_type
, 0));
3206 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, leadz
);
3209 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3211 The conditional expression is necessary because the result of TRAILZ(0)
3212 is defined, but the result of __builtin_ctz(0) is undefined for most
3216 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
3227 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3228 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3230 /* Which variant of __builtin_ctz* should we call? */
3231 if (argsize
<= INT_TYPE_SIZE
)
3233 arg_type
= unsigned_type_node
;
3234 func
= built_in_decls
[BUILT_IN_CTZ
];
3236 else if (argsize
<= LONG_TYPE_SIZE
)
3238 arg_type
= long_unsigned_type_node
;
3239 func
= built_in_decls
[BUILT_IN_CTZL
];
3241 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3243 arg_type
= long_long_unsigned_type_node
;
3244 func
= built_in_decls
[BUILT_IN_CTZLL
];
3248 gcc_assert (argsize
== 128);
3249 arg_type
= gfc_build_uint_type (argsize
);
3250 func
= gfor_fndecl_ctz128
;
3253 /* Convert the actual argument twice: first, to the unsigned type of the
3254 same size; then, to the proper argument type for the built-in
3255 function. But the return type is of the default INTEGER kind. */
3256 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3257 arg
= fold_convert (arg_type
, arg
);
3258 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3260 /* Compute TRAILZ for the case i .ne. 0. */
3261 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
3264 /* Build BIT_SIZE. */
3265 bit_size
= build_int_cst (result_type
, argsize
);
3267 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3268 arg
, build_int_cst (arg_type
, 0));
3269 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, trailz
);
3272 /* Process an intrinsic with unspecified argument-types that has an optional
3273 argument (which could be of type character), e.g. EOSHIFT. For those, we
3274 need to append the string length of the optional argument if it is not
3275 present and the type is really character.
3276 primary specifies the position (starting at 1) of the non-optional argument
3277 specifying the type and optional gives the position of the optional
3278 argument in the arglist. */
3281 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
3282 unsigned primary
, unsigned optional
)
3284 gfc_actual_arglist
* prim_arg
;
3285 gfc_actual_arglist
* opt_arg
;
3287 gfc_actual_arglist
* arg
;
3289 VEC(tree
,gc
) *append_args
;
3291 /* Find the two arguments given as position. */
3295 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3299 if (cur_pos
== primary
)
3301 if (cur_pos
== optional
)
3304 if (cur_pos
>= primary
&& cur_pos
>= optional
)
3307 gcc_assert (prim_arg
);
3308 gcc_assert (prim_arg
->expr
);
3309 gcc_assert (opt_arg
);
3311 /* If we do have type CHARACTER and the optional argument is really absent,
3312 append a dummy 0 as string length. */
3314 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
3318 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
3319 append_args
= VEC_alloc (tree
, gc
, 1);
3320 VEC_quick_push (tree
, append_args
, dummy
);
3323 /* Build the call itself. */
3324 sym
= gfc_get_symbol_for_expr (expr
);
3325 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3331 /* The length of a character string. */
3333 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
3343 gcc_assert (!se
->ss
);
3345 arg
= expr
->value
.function
.actual
->expr
;
3347 type
= gfc_typenode_for_spec (&expr
->ts
);
3348 switch (arg
->expr_type
)
3351 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
3355 /* Obtain the string length from the function used by
3356 trans-array.c(gfc_trans_array_constructor). */
3358 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
3362 if (arg
->ref
== NULL
3363 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
3365 /* This doesn't catch all cases.
3366 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3367 and the surrounding thread. */
3368 sym
= arg
->symtree
->n
.sym
;
3369 decl
= gfc_get_symbol_decl (sym
);
3370 if (decl
== current_function_decl
&& sym
->attr
.function
3371 && (sym
->result
== sym
))
3372 decl
= gfc_get_fake_result_decl (sym
, 0);
3374 len
= sym
->ts
.u
.cl
->backend_decl
;
3379 /* Otherwise fall through. */
3382 /* Anybody stupid enough to do this deserves inefficient code. */
3383 ss
= gfc_walk_expr (arg
);
3384 gfc_init_se (&argse
, se
);
3385 if (ss
== gfc_ss_terminator
)
3386 gfc_conv_expr (&argse
, arg
);
3388 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3389 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3390 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3391 len
= argse
.string_length
;
3394 se
->expr
= convert (type
, len
);
3397 /* The length of a character string not including trailing blanks. */
3399 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
3401 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
3402 tree args
[2], type
, fndecl
;
3404 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3405 type
= gfc_typenode_for_spec (&expr
->ts
);
3408 fndecl
= gfor_fndecl_string_len_trim
;
3410 fndecl
= gfor_fndecl_string_len_trim_char4
;
3414 se
->expr
= build_call_expr_loc (input_location
,
3415 fndecl
, 2, args
[0], args
[1]);
3416 se
->expr
= convert (type
, se
->expr
);
3420 /* Returns the starting position of a substring within a string. */
3423 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
3426 tree logical4_type_node
= gfc_get_logical_type (4);
3430 unsigned int num_args
;
3432 args
= (tree
*) alloca (sizeof (tree
) * 5);
3434 /* Get number of arguments; characters count double due to the
3435 string length argument. Kind= is not passed to the library
3436 and thus ignored. */
3437 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
3442 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3443 type
= gfc_typenode_for_spec (&expr
->ts
);
3446 args
[4] = build_int_cst (logical4_type_node
, 0);
3448 args
[4] = convert (logical4_type_node
, args
[4]);
3450 fndecl
= build_addr (function
, current_function_decl
);
3451 se
->expr
= build_call_array_loc (input_location
,
3452 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3454 se
->expr
= convert (type
, se
->expr
);
3458 /* The ascii value for a single character. */
3460 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
3462 tree args
[2], type
, pchartype
;
3464 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3465 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
3466 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
3467 args
[1] = fold_build1 (NOP_EXPR
, pchartype
, args
[1]);
3468 type
= gfc_typenode_for_spec (&expr
->ts
);
3470 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3472 se
->expr
= convert (type
, se
->expr
);
3476 /* Intrinsic ISNAN calls __builtin_isnan. */
3479 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
3483 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3484 se
->expr
= build_call_expr_loc (input_location
,
3485 built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
3486 STRIP_TYPE_NOPS (se
->expr
);
3487 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3491 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3492 their argument against a constant integer value. */
3495 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
3499 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3500 se
->expr
= fold_build2 (EQ_EXPR
, gfc_typenode_for_spec (&expr
->ts
),
3501 arg
, build_int_cst (TREE_TYPE (arg
), value
));
3506 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3509 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
3517 unsigned int num_args
;
3519 num_args
= gfc_intrinsic_argument_list_length (expr
);
3520 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
3522 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3523 if (expr
->ts
.type
!= BT_CHARACTER
)
3531 /* We do the same as in the non-character case, but the argument
3532 list is different because of the string length arguments. We
3533 also have to set the string length for the result. */
3540 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
3542 se
->string_length
= len
;
3544 type
= TREE_TYPE (tsource
);
3545 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
,
3546 fold_convert (type
, fsource
));
3550 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3552 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
3554 tree arg
, type
, tmp
, frexp
;
3556 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3558 type
= gfc_typenode_for_spec (&expr
->ts
);
3559 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3560 tmp
= gfc_create_var (integer_type_node
, NULL
);
3561 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
3562 fold_convert (type
, arg
),
3563 gfc_build_addr_expr (NULL_TREE
, tmp
));
3564 se
->expr
= fold_convert (type
, se
->expr
);
3568 /* NEAREST (s, dir) is translated into
3569 tmp = copysign (HUGE_VAL, dir);
3570 return nextafter (s, tmp);
3573 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
3575 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
3577 nextafter
= builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
3578 copysign
= builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3579 huge_val
= builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL
, expr
->ts
.kind
);
3581 type
= gfc_typenode_for_spec (&expr
->ts
);
3582 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3583 tmp
= build_call_expr_loc (input_location
, copysign
, 2,
3584 build_call_expr_loc (input_location
, huge_val
, 0),
3585 fold_convert (type
, args
[1]));
3586 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
3587 fold_convert (type
, args
[0]), tmp
);
3588 se
->expr
= fold_convert (type
, se
->expr
);
3592 /* SPACING (s) is translated into
3600 e = MAX_EXPR (e, emin);
3601 res = scalbn (1., e);
3605 where prec is the precision of s, gfc_real_kinds[k].digits,
3606 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3607 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3610 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
3612 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
3613 tree cond
, tmp
, frexp
, scalbn
;
3617 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3618 prec
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].digits
);
3619 emin
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].min_exponent
- 1);
3620 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
3622 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3623 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3625 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3626 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3628 type
= gfc_typenode_for_spec (&expr
->ts
);
3629 e
= gfc_create_var (integer_type_node
, NULL
);
3630 res
= gfc_create_var (type
, NULL
);
3633 /* Build the block for s /= 0. */
3634 gfc_start_block (&block
);
3635 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
3636 gfc_build_addr_expr (NULL_TREE
, e
));
3637 gfc_add_expr_to_block (&block
, tmp
);
3639 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, e
, prec
);
3640 gfc_add_modify (&block
, e
, fold_build2 (MAX_EXPR
, integer_type_node
,
3643 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
3644 build_real_from_int_cst (type
, integer_one_node
), e
);
3645 gfc_add_modify (&block
, res
, tmp
);
3647 /* Finish by building the IF statement. */
3648 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg
,
3649 build_real_from_int_cst (type
, integer_zero_node
));
3650 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
3651 gfc_finish_block (&block
));
3653 gfc_add_expr_to_block (&se
->pre
, tmp
);
3658 /* RRSPACING (s) is translated into
3665 x = scalbn (x, precision - e);
3669 where precision is gfc_real_kinds[k].digits. */
3672 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
3674 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
3678 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3679 prec
= gfc_real_kinds
[k
].digits
;
3681 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3682 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3683 fabs
= builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3685 type
= gfc_typenode_for_spec (&expr
->ts
);
3686 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3687 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3689 e
= gfc_create_var (integer_type_node
, NULL
);
3690 x
= gfc_create_var (type
, NULL
);
3691 gfc_add_modify (&se
->pre
, x
,
3692 build_call_expr_loc (input_location
, fabs
, 1, arg
));
3695 gfc_start_block (&block
);
3696 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
3697 gfc_build_addr_expr (NULL_TREE
, e
));
3698 gfc_add_expr_to_block (&block
, tmp
);
3700 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
,
3701 build_int_cst (NULL_TREE
, prec
), e
);
3702 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
3703 gfc_add_modify (&block
, x
, tmp
);
3704 stmt
= gfc_finish_block (&block
);
3706 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, x
,
3707 build_real_from_int_cst (type
, integer_zero_node
));
3708 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
3709 gfc_add_expr_to_block (&se
->pre
, tmp
);
3711 se
->expr
= fold_convert (type
, x
);
3715 /* SCALE (s, i) is translated into scalbn (s, i). */
3717 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
3719 tree args
[2], type
, scalbn
;
3721 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3723 type
= gfc_typenode_for_spec (&expr
->ts
);
3724 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3725 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
3726 fold_convert (type
, args
[0]),
3727 fold_convert (integer_type_node
, args
[1]));
3728 se
->expr
= fold_convert (type
, se
->expr
);
3732 /* SET_EXPONENT (s, i) is translated into
3733 scalbn (frexp (s, &dummy_int), i). */
3735 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
3737 tree args
[2], type
, tmp
, frexp
, scalbn
;
3739 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3740 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3742 type
= gfc_typenode_for_spec (&expr
->ts
);
3743 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3745 tmp
= gfc_create_var (integer_type_node
, NULL
);
3746 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
3747 fold_convert (type
, args
[0]),
3748 gfc_build_addr_expr (NULL_TREE
, tmp
));
3749 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
3750 fold_convert (integer_type_node
, args
[1]));
3751 se
->expr
= fold_convert (type
, se
->expr
);
3756 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
3758 gfc_actual_arglist
*actual
;
3766 gfc_init_se (&argse
, NULL
);
3767 actual
= expr
->value
.function
.actual
;
3769 ss
= gfc_walk_expr (actual
->expr
);
3770 gcc_assert (ss
!= gfc_ss_terminator
);
3771 argse
.want_pointer
= 1;
3772 argse
.data_not_needed
= 1;
3773 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
3774 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3775 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3776 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
3778 /* Build the call to size0. */
3779 fncall0
= build_call_expr_loc (input_location
,
3780 gfor_fndecl_size0
, 1, arg1
);
3782 actual
= actual
->next
;
3786 gfc_init_se (&argse
, NULL
);
3787 gfc_conv_expr_type (&argse
, actual
->expr
,
3788 gfc_array_index_type
);
3789 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3791 /* Unusually, for an intrinsic, size does not exclude
3792 an optional arg2, so we must test for it. */
3793 if (actual
->expr
->expr_type
== EXPR_VARIABLE
3794 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
3795 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
3798 /* Build the call to size1. */
3799 fncall1
= build_call_expr_loc (input_location
,
3800 gfor_fndecl_size1
, 2,
3803 gfc_init_se (&argse
, NULL
);
3804 argse
.want_pointer
= 1;
3805 argse
.data_not_needed
= 1;
3806 gfc_conv_expr (&argse
, actual
->expr
);
3807 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3808 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3809 argse
.expr
, null_pointer_node
);
3810 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3811 se
->expr
= fold_build3 (COND_EXPR
, pvoid_type_node
,
3812 tmp
, fncall1
, fncall0
);
3816 se
->expr
= NULL_TREE
;
3817 argse
.expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3818 argse
.expr
, gfc_index_one_node
);
3821 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
3823 argse
.expr
= gfc_index_zero_node
;
3824 se
->expr
= NULL_TREE
;
3829 if (se
->expr
== NULL_TREE
)
3831 tree ubound
, lbound
;
3833 arg1
= build_fold_indirect_ref_loc (input_location
,
3835 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
3836 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
3837 se
->expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3839 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
->expr
,
3840 gfc_index_one_node
);
3841 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
3842 gfc_index_zero_node
);
3845 type
= gfc_typenode_for_spec (&expr
->ts
);
3846 se
->expr
= convert (type
, se
->expr
);
3850 /* Helper function to compute the size of a character variable,
3851 excluding the terminating null characters. The result has
3852 gfc_array_index_type type. */
3855 size_of_string_in_bytes (int kind
, tree string_length
)
3858 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
3860 bytesize
= build_int_cst (gfc_array_index_type
,
3861 gfc_character_kinds
[i
].bit_size
/ 8);
3863 return fold_build2 (MULT_EXPR
, gfc_array_index_type
, bytesize
,
3864 fold_convert (gfc_array_index_type
, string_length
));
3869 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
3881 arg
= expr
->value
.function
.actual
->expr
;
3883 gfc_init_se (&argse
, NULL
);
3884 ss
= gfc_walk_expr (arg
);
3886 if (ss
== gfc_ss_terminator
)
3888 if (arg
->ts
.type
== BT_CLASS
)
3889 gfc_add_component_ref (arg
, "$data");
3891 gfc_conv_expr_reference (&argse
, arg
);
3893 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
3896 /* Obtain the source word length. */
3897 if (arg
->ts
.type
== BT_CHARACTER
)
3898 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
3899 argse
.string_length
);
3901 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
3905 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
3906 argse
.want_pointer
= 0;
3907 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3908 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3910 /* Obtain the argument's word length. */
3911 if (arg
->ts
.type
== BT_CHARACTER
)
3912 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
3914 tmp
= fold_convert (gfc_array_index_type
,
3915 size_in_bytes (type
));
3916 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3918 /* Obtain the size of the array in bytes. */
3919 for (n
= 0; n
< arg
->rank
; n
++)
3922 idx
= gfc_rank_cst
[n
];
3923 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
3924 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
3925 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3927 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3928 tmp
, gfc_index_one_node
);
3929 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3931 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3933 se
->expr
= source_bytes
;
3936 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3941 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
3946 tree type
, result_type
, tmp
;
3948 arg
= expr
->value
.function
.actual
->expr
;
3949 gfc_init_se (&eight
, NULL
);
3950 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
3952 gfc_init_se (&argse
, NULL
);
3953 ss
= gfc_walk_expr (arg
);
3954 result_type
= gfc_get_int_type (expr
->ts
.kind
);
3956 if (ss
== gfc_ss_terminator
)
3958 if (arg
->ts
.type
== BT_CLASS
)
3960 gfc_add_component_ref (arg
, "$vptr");
3961 gfc_add_component_ref (arg
, "$size");
3962 gfc_conv_expr (&argse
, arg
);
3963 tmp
= fold_convert (result_type
, argse
.expr
);
3967 gfc_conv_expr_reference (&argse
, arg
);
3968 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
3973 argse
.want_pointer
= 0;
3974 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3975 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3978 /* Obtain the argument's word length. */
3979 if (arg
->ts
.type
== BT_CHARACTER
)
3980 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
3982 tmp
= fold_convert (result_type
, size_in_bytes (type
));
3985 se
->expr
= fold_build2 (MULT_EXPR
, result_type
, tmp
, eight
.expr
);
3986 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3990 /* Intrinsic string comparison functions. */
3993 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3997 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
4000 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
4001 expr
->value
.function
.actual
->expr
->ts
.kind
,
4003 se
->expr
= fold_build2 (op
, gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
4004 build_int_cst (TREE_TYPE (se
->expr
), 0));
4007 /* Generate a call to the adjustl/adjustr library function. */
4009 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
4017 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
4020 type
= TREE_TYPE (args
[2]);
4021 var
= gfc_conv_string_tmp (se
, type
, len
);
4024 tmp
= build_call_expr_loc (input_location
,
4025 fndecl
, 3, args
[0], args
[1], args
[2]);
4026 gfc_add_expr_to_block (&se
->pre
, tmp
);
4028 se
->string_length
= len
;
4032 /* Generate code for the TRANSFER intrinsic:
4034 DEST = TRANSFER (SOURCE, MOLD)
4036 typeof<DEST> = typeof<MOLD>
4041 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4043 typeof<DEST> = typeof<MOLD>
4045 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4046 sizeof (DEST(0) * SIZE). */
4048 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
4064 gfc_actual_arglist
*arg
;
4074 info
= &se
->ss
->data
.info
;
4076 /* Convert SOURCE. The output from this stage is:-
4077 source_bytes = length of the source in bytes
4078 source = pointer to the source data. */
4079 arg
= expr
->value
.function
.actual
;
4081 /* Ensure double transfer through LOGICAL preserves all
4083 if (arg
->expr
->expr_type
== EXPR_FUNCTION
4084 && arg
->expr
->value
.function
.esym
== NULL
4085 && arg
->expr
->value
.function
.isym
!= NULL
4086 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
4087 && arg
->expr
->ts
.type
== BT_LOGICAL
4088 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
4089 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
4091 gfc_init_se (&argse
, NULL
);
4092 ss
= gfc_walk_expr (arg
->expr
);
4094 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
4096 /* Obtain the pointer to source and the length of source in bytes. */
4097 if (ss
== gfc_ss_terminator
)
4099 gfc_conv_expr_reference (&argse
, arg
->expr
);
4100 source
= argse
.expr
;
4102 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4105 /* Obtain the source word length. */
4106 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4107 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
4108 argse
.string_length
);
4110 tmp
= fold_convert (gfc_array_index_type
,
4111 size_in_bytes (source_type
));
4115 argse
.want_pointer
= 0;
4116 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
4117 source
= gfc_conv_descriptor_data_get (argse
.expr
);
4118 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4120 /* Repack the source if not a full variable array. */
4121 if (arg
->expr
->expr_type
== EXPR_VARIABLE
4122 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
4124 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
4126 if (gfc_option
.warn_array_temp
)
4127 gfc_warning ("Creating array temporary at %L", &expr
->where
);
4129 source
= build_call_expr_loc (input_location
,
4130 gfor_fndecl_in_pack
, 1, tmp
);
4131 source
= gfc_evaluate_now (source
, &argse
.pre
);
4133 /* Free the temporary. */
4134 gfc_start_block (&block
);
4135 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
4136 gfc_add_expr_to_block (&block
, tmp
);
4137 stmt
= gfc_finish_block (&block
);
4139 /* Clean up if it was repacked. */
4140 gfc_init_block (&block
);
4141 tmp
= gfc_conv_array_data (argse
.expr
);
4142 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
4143 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
4144 build_empty_stmt (input_location
));
4145 gfc_add_expr_to_block (&block
, tmp
);
4146 gfc_add_block_to_block (&block
, &se
->post
);
4147 gfc_init_block (&se
->post
);
4148 gfc_add_block_to_block (&se
->post
, &block
);
4151 /* Obtain the source word length. */
4152 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4153 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
4154 argse
.string_length
);
4156 tmp
= fold_convert (gfc_array_index_type
,
4157 size_in_bytes (source_type
));
4159 /* Obtain the size of the array in bytes. */
4160 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
4161 for (n
= 0; n
< arg
->expr
->rank
; n
++)
4164 idx
= gfc_rank_cst
[n
];
4165 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4166 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
4167 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
4168 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4170 gfc_add_modify (&argse
.pre
, extent
, tmp
);
4171 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4172 extent
, gfc_index_one_node
);
4173 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4178 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4179 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4180 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4182 /* Now convert MOLD. The outputs are:
4183 mold_type = the TREE type of MOLD
4184 dest_word_len = destination word length in bytes. */
4187 gfc_init_se (&argse
, NULL
);
4188 ss
= gfc_walk_expr (arg
->expr
);
4190 scalar_mold
= arg
->expr
->rank
== 0;
4192 if (ss
== gfc_ss_terminator
)
4194 gfc_conv_expr_reference (&argse
, arg
->expr
);
4195 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4200 gfc_init_se (&argse
, NULL
);
4201 argse
.want_pointer
= 0;
4202 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
4203 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4206 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4207 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4209 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
4211 /* If this TRANSFER is nested in another TRANSFER, use a type
4212 that preserves all bits. */
4213 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
4214 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
4217 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4219 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
4220 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
4223 tmp
= fold_convert (gfc_array_index_type
,
4224 size_in_bytes (mold_type
));
4226 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
4227 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
4229 /* Finally convert SIZE, if it is present. */
4231 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
4235 gfc_init_se (&argse
, NULL
);
4236 gfc_conv_expr_reference (&argse
, arg
->expr
);
4237 tmp
= convert (gfc_array_index_type
,
4238 build_fold_indirect_ref_loc (input_location
,
4240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4246 /* Separate array and scalar results. */
4247 if (scalar_mold
&& tmp
== NULL_TREE
)
4248 goto scalar_transfer
;
4250 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
4251 if (tmp
!= NULL_TREE
)
4252 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4253 tmp
, dest_word_len
);
4257 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
4258 gfc_add_modify (&se
->pre
, size_words
,
4259 fold_build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
4260 size_bytes
, dest_word_len
));
4262 /* Evaluate the bounds of the result. If the loop range exists, we have
4263 to check if it is too large. If so, we modify loop->to be consistent
4264 with min(size, size(source)). Otherwise, size is made consistent with
4265 the loop range, so that the right number of bytes is transferred.*/
4266 n
= se
->loop
->order
[0];
4267 if (se
->loop
->to
[n
] != NULL_TREE
)
4269 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4270 se
->loop
->to
[n
], se
->loop
->from
[n
]);
4271 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4272 tmp
, gfc_index_one_node
);
4273 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
4275 gfc_add_modify (&se
->pre
, size_words
, tmp
);
4276 gfc_add_modify (&se
->pre
, size_bytes
,
4277 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4278 size_words
, dest_word_len
));
4279 upper
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4280 size_words
, se
->loop
->from
[n
]);
4281 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4282 upper
, gfc_index_one_node
);
4286 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4287 size_words
, gfc_index_one_node
);
4288 se
->loop
->from
[n
] = gfc_index_zero_node
;
4291 se
->loop
->to
[n
] = upper
;
4293 /* Build a destination descriptor, using the pointer, source, as the
4295 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
4296 info
, mold_type
, NULL_TREE
, false, true, false,
4299 /* Cast the pointer to the result. */
4300 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
4301 tmp
= fold_convert (pvoid_type_node
, tmp
);
4303 /* Use memcpy to do the transfer. */
4304 tmp
= build_call_expr_loc (input_location
,
4305 built_in_decls
[BUILT_IN_MEMCPY
],
4308 fold_convert (pvoid_type_node
, source
),
4309 fold_build2 (MIN_EXPR
, gfc_array_index_type
,
4310 size_bytes
, source_bytes
));
4311 gfc_add_expr_to_block (&se
->pre
, tmp
);
4313 se
->expr
= info
->descriptor
;
4314 if (expr
->ts
.type
== BT_CHARACTER
)
4315 se
->string_length
= dest_word_len
;
4319 /* Deal with scalar results. */
4321 extent
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
4322 dest_word_len
, source_bytes
);
4323 extent
= fold_build2 (MAX_EXPR
, gfc_array_index_type
,
4324 extent
, gfc_index_zero_node
);
4326 if (expr
->ts
.type
== BT_CHARACTER
)
4331 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
4332 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
4335 /* If source is longer than the destination, use a pointer to
4336 the source directly. */
4337 gfc_init_block (&block
);
4338 gfc_add_modify (&block
, tmpdecl
, ptr
);
4339 direct
= gfc_finish_block (&block
);
4341 /* Otherwise, allocate a string with the length of the destination
4342 and copy the source into it. */
4343 gfc_init_block (&block
);
4344 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
4345 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
4346 gfc_add_modify (&block
, tmpdecl
,
4347 fold_convert (TREE_TYPE (ptr
), tmp
));
4348 tmp
= build_call_expr_loc (input_location
,
4349 built_in_decls
[BUILT_IN_MEMCPY
], 3,
4350 fold_convert (pvoid_type_node
, tmpdecl
),
4351 fold_convert (pvoid_type_node
, ptr
),
4353 gfc_add_expr_to_block (&block
, tmp
);
4354 indirect
= gfc_finish_block (&block
);
4356 /* Wrap it up with the condition. */
4357 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
,
4358 dest_word_len
, source_bytes
);
4359 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
4360 gfc_add_expr_to_block (&se
->pre
, tmp
);
4363 se
->string_length
= dest_word_len
;
4367 tmpdecl
= gfc_create_var (mold_type
, "transfer");
4369 ptr
= convert (build_pointer_type (mold_type
), source
);
4371 /* Use memcpy to do the transfer. */
4372 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
4373 tmp
= build_call_expr_loc (input_location
,
4374 built_in_decls
[BUILT_IN_MEMCPY
], 3,
4375 fold_convert (pvoid_type_node
, tmp
),
4376 fold_convert (pvoid_type_node
, ptr
),
4378 gfc_add_expr_to_block (&se
->pre
, tmp
);
4385 /* Generate code for the ALLOCATED intrinsic.
4386 Generate inline code that directly check the address of the argument. */
4389 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
4391 gfc_actual_arglist
*arg1
;
4396 gfc_init_se (&arg1se
, NULL
);
4397 arg1
= expr
->value
.function
.actual
;
4398 ss1
= gfc_walk_expr (arg1
->expr
);
4400 if (ss1
== gfc_ss_terminator
)
4402 /* Allocatable scalar. */
4403 arg1se
.want_pointer
= 1;
4404 if (arg1
->expr
->ts
.type
== BT_CLASS
)
4405 gfc_add_component_ref (arg1
->expr
, "$data");
4406 gfc_conv_expr (&arg1se
, arg1
->expr
);
4411 /* Allocatable array. */
4412 arg1se
.descriptor_only
= 1;
4413 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4414 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
4417 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
4418 tmp
, fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
4419 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
4423 /* Generate code for the ASSOCIATED intrinsic.
4424 If both POINTER and TARGET are arrays, generate a call to library function
4425 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4426 In other cases, generate inline code that directly compare the address of
4427 POINTER with the address of TARGET. */
4430 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
4432 gfc_actual_arglist
*arg1
;
4433 gfc_actual_arglist
*arg2
;
4438 tree nonzero_charlen
;
4439 tree nonzero_arraylen
;
4442 gfc_init_se (&arg1se
, NULL
);
4443 gfc_init_se (&arg2se
, NULL
);
4444 arg1
= expr
->value
.function
.actual
;
4445 if (arg1
->expr
->ts
.type
== BT_CLASS
)
4446 gfc_add_component_ref (arg1
->expr
, "$data");
4448 ss1
= gfc_walk_expr (arg1
->expr
);
4452 /* No optional target. */
4453 if (ss1
== gfc_ss_terminator
)
4455 /* A pointer to a scalar. */
4456 arg1se
.want_pointer
= 1;
4457 gfc_conv_expr (&arg1se
, arg1
->expr
);
4462 /* A pointer to an array. */
4463 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4464 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
4466 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
4467 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
4468 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp2
,
4469 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
4474 /* An optional target. */
4475 if (arg2
->expr
->ts
.type
== BT_CLASS
)
4476 gfc_add_component_ref (arg2
->expr
, "$data");
4477 ss2
= gfc_walk_expr (arg2
->expr
);
4479 nonzero_charlen
= NULL_TREE
;
4480 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
4481 nonzero_charlen
= fold_build2 (NE_EXPR
, boolean_type_node
,
4482 arg1
->expr
->ts
.u
.cl
->backend_decl
,
4485 if (ss1
== gfc_ss_terminator
)
4487 /* A pointer to a scalar. */
4488 gcc_assert (ss2
== gfc_ss_terminator
);
4489 arg1se
.want_pointer
= 1;
4490 gfc_conv_expr (&arg1se
, arg1
->expr
);
4491 arg2se
.want_pointer
= 1;
4492 gfc_conv_expr (&arg2se
, arg2
->expr
);
4493 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
4494 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
4495 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4496 arg1se
.expr
, arg2se
.expr
);
4497 tmp2
= fold_build2 (NE_EXPR
, boolean_type_node
,
4498 arg1se
.expr
, null_pointer_node
);
4499 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4504 /* An array pointer of zero length is not associated if target is
4506 arg1se
.descriptor_only
= 1;
4507 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
4508 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
,
4509 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
4510 nonzero_arraylen
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
4511 build_int_cst (TREE_TYPE (tmp
), 0));
4513 /* A pointer to an array, call library function _gfor_associated. */
4514 gcc_assert (ss2
!= gfc_ss_terminator
);
4515 arg1se
.want_pointer
= 1;
4516 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4518 arg2se
.want_pointer
= 1;
4519 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
4520 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
4521 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
4522 se
->expr
= build_call_expr_loc (input_location
,
4523 gfor_fndecl_associated
, 2,
4524 arg1se
.expr
, arg2se
.expr
);
4525 se
->expr
= convert (boolean_type_node
, se
->expr
);
4526 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4527 se
->expr
, nonzero_arraylen
);
4530 /* If target is present zero character length pointers cannot
4532 if (nonzero_charlen
!= NULL_TREE
)
4533 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4534 se
->expr
, nonzero_charlen
);
4537 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4541 /* Generate code for the SAME_TYPE_AS intrinsic.
4542 Generate inline code that directly checks the vindices. */
4545 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
4551 gfc_init_se (&se1
, NULL
);
4552 gfc_init_se (&se2
, NULL
);
4554 a
= expr
->value
.function
.actual
->expr
;
4555 b
= expr
->value
.function
.actual
->next
->expr
;
4557 if (a
->ts
.type
== BT_CLASS
)
4559 gfc_add_component_ref (a
, "$vptr");
4560 gfc_add_component_ref (a
, "$hash");
4562 else if (a
->ts
.type
== BT_DERIVED
)
4563 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4564 a
->ts
.u
.derived
->hash_value
);
4566 if (b
->ts
.type
== BT_CLASS
)
4568 gfc_add_component_ref (b
, "$vptr");
4569 gfc_add_component_ref (b
, "$hash");
4571 else if (b
->ts
.type
== BT_DERIVED
)
4572 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4573 b
->ts
.u
.derived
->hash_value
);
4575 gfc_conv_expr (&se1
, a
);
4576 gfc_conv_expr (&se2
, b
);
4578 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4579 se1
.expr
, fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
4580 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
4584 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4587 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
4591 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4592 se
->expr
= build_call_expr_loc (input_location
,
4593 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
4594 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4598 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4601 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
4605 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4607 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4608 type
= gfc_get_int_type (4);
4609 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
4611 /* Convert it to the required type. */
4612 type
= gfc_typenode_for_spec (&expr
->ts
);
4613 se
->expr
= build_call_expr_loc (input_location
,
4614 gfor_fndecl_si_kind
, 1, arg
);
4615 se
->expr
= fold_convert (type
, se
->expr
);
4619 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4622 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
4624 gfc_actual_arglist
*actual
;
4627 VEC(tree
,gc
) *args
= NULL
;
4629 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4631 gfc_init_se (&argse
, se
);
4633 /* Pass a NULL pointer for an absent arg. */
4634 if (actual
->expr
== NULL
)
4635 argse
.expr
= null_pointer_node
;
4641 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4643 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4644 ts
.type
= BT_INTEGER
;
4645 ts
.kind
= gfc_c_int_kind
;
4646 gfc_convert_type (actual
->expr
, &ts
, 2);
4648 gfc_conv_expr_reference (&argse
, actual
->expr
);
4651 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4652 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4653 VEC_safe_push (tree
, gc
, args
, argse
.expr
);
4656 /* Convert it to the required type. */
4657 type
= gfc_typenode_for_spec (&expr
->ts
);
4658 se
->expr
= build_call_expr_loc_vec (input_location
,
4659 gfor_fndecl_sr_kind
, args
);
4660 se
->expr
= fold_convert (type
, se
->expr
);
4664 /* Generate code for TRIM (A) intrinsic function. */
4667 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
4677 unsigned int num_args
;
4679 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4680 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
4682 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4683 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
4684 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4686 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4687 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4690 if (expr
->ts
.kind
== 1)
4691 function
= gfor_fndecl_string_trim
;
4692 else if (expr
->ts
.kind
== 4)
4693 function
= gfor_fndecl_string_trim_char4
;
4697 fndecl
= build_addr (function
, current_function_decl
);
4698 tmp
= build_call_array_loc (input_location
,
4699 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4701 gfc_add_expr_to_block (&se
->pre
, tmp
);
4703 /* Free the temporary afterwards, if necessary. */
4704 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4705 len
, build_int_cst (TREE_TYPE (len
), 0));
4706 tmp
= gfc_call_free (var
);
4707 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4708 gfc_add_expr_to_block (&se
->post
, tmp
);
4711 se
->string_length
= len
;
4715 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
4718 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
4720 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
4721 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
4723 stmtblock_t block
, body
;
4726 /* We store in charsize the size of a character. */
4727 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
4728 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
4730 /* Get the arguments. */
4731 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4732 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
4734 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
4735 ncopies_type
= TREE_TYPE (ncopies
);
4737 /* Check that NCOPIES is not negative. */
4738 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
4739 build_int_cst (ncopies_type
, 0));
4740 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4741 "Argument NCOPIES of REPEAT intrinsic is negative "
4742 "(its value is %lld)",
4743 fold_convert (long_integer_type_node
, ncopies
));
4745 /* If the source length is zero, any non negative value of NCOPIES
4746 is valid, and nothing happens. */
4747 n
= gfc_create_var (ncopies_type
, "ncopies");
4748 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4749 build_int_cst (size_type_node
, 0));
4750 tmp
= fold_build3 (COND_EXPR
, ncopies_type
, cond
,
4751 build_int_cst (ncopies_type
, 0), ncopies
);
4752 gfc_add_modify (&se
->pre
, n
, tmp
);
4755 /* Check that ncopies is not too large: ncopies should be less than
4756 (or equal to) MAX / slen, where MAX is the maximal integer of
4757 the gfc_charlen_type_node type. If slen == 0, we need a special
4758 case to avoid the division by zero. */
4759 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4760 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
4761 max
= fold_build2 (TRUNC_DIV_EXPR
, size_type_node
,
4762 fold_convert (size_type_node
, max
), slen
);
4763 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
4764 ? size_type_node
: ncopies_type
;
4765 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4766 fold_convert (largest
, ncopies
),
4767 fold_convert (largest
, max
));
4768 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4769 build_int_cst (size_type_node
, 0));
4770 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
, boolean_false_node
,
4772 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4773 "Argument NCOPIES of REPEAT intrinsic is too large");
4775 /* Compute the destination length. */
4776 dlen
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4777 fold_convert (gfc_charlen_type_node
, slen
),
4778 fold_convert (gfc_charlen_type_node
, ncopies
));
4779 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
4780 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
4782 /* Generate the code to do the repeat operation:
4783 for (i = 0; i < ncopies; i++)
4784 memmove (dest + (i * slen * size), src, slen*size); */
4785 gfc_start_block (&block
);
4786 count
= gfc_create_var (ncopies_type
, "count");
4787 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
4788 exit_label
= gfc_build_label_decl (NULL_TREE
);
4790 /* Start the loop body. */
4791 gfc_start_block (&body
);
4793 /* Exit the loop if count >= ncopies. */
4794 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, count
, ncopies
);
4795 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4796 TREE_USED (exit_label
) = 1;
4797 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
4798 build_empty_stmt (input_location
));
4799 gfc_add_expr_to_block (&body
, tmp
);
4801 /* Call memmove (dest + (i*slen*size), src, slen*size). */
4802 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4803 fold_convert (gfc_charlen_type_node
, slen
),
4804 fold_convert (gfc_charlen_type_node
, count
));
4805 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4806 tmp
, fold_convert (gfc_charlen_type_node
, size
));
4807 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pvoid_type_node
,
4808 fold_convert (pvoid_type_node
, dest
),
4809 fold_convert (sizetype
, tmp
));
4810 tmp
= build_call_expr_loc (input_location
,
4811 built_in_decls
[BUILT_IN_MEMMOVE
], 3, tmp
, src
,
4812 fold_build2 (MULT_EXPR
, size_type_node
, slen
,
4813 fold_convert (size_type_node
, size
)));
4814 gfc_add_expr_to_block (&body
, tmp
);
4816 /* Increment count. */
4817 tmp
= fold_build2 (PLUS_EXPR
, ncopies_type
,
4818 count
, build_int_cst (TREE_TYPE (count
), 1));
4819 gfc_add_modify (&body
, count
, tmp
);
4821 /* Build the loop. */
4822 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
4823 gfc_add_expr_to_block (&block
, tmp
);
4825 /* Add the exit label. */
4826 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4827 gfc_add_expr_to_block (&block
, tmp
);
4829 /* Finish the block. */
4830 tmp
= gfc_finish_block (&block
);
4831 gfc_add_expr_to_block (&se
->pre
, tmp
);
4833 /* Set the result value. */
4835 se
->string_length
= dlen
;
4839 /* Generate code for the IARGC intrinsic. */
4842 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
4848 /* Call the library function. This always returns an INTEGER(4). */
4849 fndecl
= gfor_fndecl_iargc
;
4850 tmp
= build_call_expr_loc (input_location
,
4853 /* Convert it to the required type. */
4854 type
= gfc_typenode_for_spec (&expr
->ts
);
4855 tmp
= fold_convert (type
, tmp
);
4861 /* The loc intrinsic returns the address of its argument as
4862 gfc_index_integer_kind integer. */
4865 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
4871 gcc_assert (!se
->ss
);
4873 arg_expr
= expr
->value
.function
.actual
->expr
;
4874 ss
= gfc_walk_expr (arg_expr
);
4875 if (ss
== gfc_ss_terminator
)
4876 gfc_conv_expr_reference (se
, arg_expr
);
4878 gfc_conv_array_parameter (se
, arg_expr
, ss
, true, NULL
, NULL
, NULL
);
4879 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
4881 /* Create a temporary variable for loc return value. Without this,
4882 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4883 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
4884 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
4885 se
->expr
= temp_var
;
4888 /* Generate code for an intrinsic function. Some map directly to library
4889 calls, others get special handling. In some cases the name of the function
4890 used depends on the type specifiers. */
4893 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
4899 name
= &expr
->value
.function
.name
[2];
4901 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
4903 lib
= gfc_is_intrinsic_libcall (expr
);
4907 se
->ignore_optional
= 1;
4909 switch (expr
->value
.function
.isym
->id
)
4911 case GFC_ISYM_EOSHIFT
:
4913 case GFC_ISYM_RESHAPE
:
4914 /* For all of those the first argument specifies the type and the
4915 third is optional. */
4916 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
4920 gfc_conv_intrinsic_funcall (se
, expr
);
4928 switch (expr
->value
.function
.isym
->id
)
4933 case GFC_ISYM_REPEAT
:
4934 gfc_conv_intrinsic_repeat (se
, expr
);
4938 gfc_conv_intrinsic_trim (se
, expr
);
4941 case GFC_ISYM_SC_KIND
:
4942 gfc_conv_intrinsic_sc_kind (se
, expr
);
4945 case GFC_ISYM_SI_KIND
:
4946 gfc_conv_intrinsic_si_kind (se
, expr
);
4949 case GFC_ISYM_SR_KIND
:
4950 gfc_conv_intrinsic_sr_kind (se
, expr
);
4953 case GFC_ISYM_EXPONENT
:
4954 gfc_conv_intrinsic_exponent (se
, expr
);
4958 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4960 fndecl
= gfor_fndecl_string_scan
;
4962 fndecl
= gfor_fndecl_string_scan_char4
;
4966 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4969 case GFC_ISYM_VERIFY
:
4970 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4972 fndecl
= gfor_fndecl_string_verify
;
4974 fndecl
= gfor_fndecl_string_verify_char4
;
4978 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4981 case GFC_ISYM_ALLOCATED
:
4982 gfc_conv_allocated (se
, expr
);
4985 case GFC_ISYM_ASSOCIATED
:
4986 gfc_conv_associated(se
, expr
);
4989 case GFC_ISYM_SAME_TYPE_AS
:
4990 gfc_conv_same_type_as (se
, expr
);
4994 gfc_conv_intrinsic_abs (se
, expr
);
4997 case GFC_ISYM_ADJUSTL
:
4998 if (expr
->ts
.kind
== 1)
4999 fndecl
= gfor_fndecl_adjustl
;
5000 else if (expr
->ts
.kind
== 4)
5001 fndecl
= gfor_fndecl_adjustl_char4
;
5005 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5008 case GFC_ISYM_ADJUSTR
:
5009 if (expr
->ts
.kind
== 1)
5010 fndecl
= gfor_fndecl_adjustr
;
5011 else if (expr
->ts
.kind
== 4)
5012 fndecl
= gfor_fndecl_adjustr_char4
;
5016 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5019 case GFC_ISYM_AIMAG
:
5020 gfc_conv_intrinsic_imagpart (se
, expr
);
5024 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
5028 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
5031 case GFC_ISYM_ANINT
:
5032 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
5036 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
5040 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
5043 case GFC_ISYM_BTEST
:
5044 gfc_conv_intrinsic_btest (se
, expr
);
5047 case GFC_ISYM_ACHAR
:
5049 gfc_conv_intrinsic_char (se
, expr
);
5052 case GFC_ISYM_CONVERSION
:
5054 case GFC_ISYM_LOGICAL
:
5056 gfc_conv_intrinsic_conversion (se
, expr
);
5059 /* Integer conversions are handled separately to make sure we get the
5060 correct rounding mode. */
5065 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
5069 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
5072 case GFC_ISYM_CEILING
:
5073 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
5076 case GFC_ISYM_FLOOR
:
5077 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
5081 gfc_conv_intrinsic_mod (se
, expr
, 0);
5084 case GFC_ISYM_MODULO
:
5085 gfc_conv_intrinsic_mod (se
, expr
, 1);
5088 case GFC_ISYM_CMPLX
:
5089 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
5092 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
5093 gfc_conv_intrinsic_iargc (se
, expr
);
5096 case GFC_ISYM_COMPLEX
:
5097 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
5100 case GFC_ISYM_CONJG
:
5101 gfc_conv_intrinsic_conjg (se
, expr
);
5104 case GFC_ISYM_COUNT
:
5105 gfc_conv_intrinsic_count (se
, expr
);
5108 case GFC_ISYM_CTIME
:
5109 gfc_conv_intrinsic_ctime (se
, expr
);
5113 gfc_conv_intrinsic_dim (se
, expr
);
5116 case GFC_ISYM_DOT_PRODUCT
:
5117 gfc_conv_intrinsic_dot_product (se
, expr
);
5120 case GFC_ISYM_DPROD
:
5121 gfc_conv_intrinsic_dprod (se
, expr
);
5124 case GFC_ISYM_FDATE
:
5125 gfc_conv_intrinsic_fdate (se
, expr
);
5128 case GFC_ISYM_FRACTION
:
5129 gfc_conv_intrinsic_fraction (se
, expr
);
5133 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
5136 case GFC_ISYM_IBCLR
:
5137 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
5140 case GFC_ISYM_IBITS
:
5141 gfc_conv_intrinsic_ibits (se
, expr
);
5144 case GFC_ISYM_IBSET
:
5145 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
5148 case GFC_ISYM_IACHAR
:
5149 case GFC_ISYM_ICHAR
:
5150 /* We assume ASCII character sequence. */
5151 gfc_conv_intrinsic_ichar (se
, expr
);
5154 case GFC_ISYM_IARGC
:
5155 gfc_conv_intrinsic_iargc (se
, expr
);
5159 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
5162 case GFC_ISYM_INDEX
:
5163 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5165 fndecl
= gfor_fndecl_string_index
;
5167 fndecl
= gfor_fndecl_string_index_char4
;
5171 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
5175 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
5178 case GFC_ISYM_IS_IOSTAT_END
:
5179 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
5182 case GFC_ISYM_IS_IOSTAT_EOR
:
5183 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
5186 case GFC_ISYM_ISNAN
:
5187 gfc_conv_intrinsic_isnan (se
, expr
);
5190 case GFC_ISYM_LSHIFT
:
5191 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
5194 case GFC_ISYM_RSHIFT
:
5195 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
5198 case GFC_ISYM_ISHFT
:
5199 gfc_conv_intrinsic_ishft (se
, expr
);
5202 case GFC_ISYM_ISHFTC
:
5203 gfc_conv_intrinsic_ishftc (se
, expr
);
5206 case GFC_ISYM_LEADZ
:
5207 gfc_conv_intrinsic_leadz (se
, expr
);
5210 case GFC_ISYM_TRAILZ
:
5211 gfc_conv_intrinsic_trailz (se
, expr
);
5214 case GFC_ISYM_LBOUND
:
5215 gfc_conv_intrinsic_bound (se
, expr
, 0);
5218 case GFC_ISYM_TRANSPOSE
:
5219 if (se
->ss
&& se
->ss
->useflags
)
5221 gfc_conv_tmp_array_ref (se
);
5222 gfc_advance_se_ss_chain (se
);
5225 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
5229 gfc_conv_intrinsic_len (se
, expr
);
5232 case GFC_ISYM_LEN_TRIM
:
5233 gfc_conv_intrinsic_len_trim (se
, expr
);
5237 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
5241 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
5245 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
5249 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
5253 if (expr
->ts
.type
== BT_CHARACTER
)
5254 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
5256 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
5259 case GFC_ISYM_MAXLOC
:
5260 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
5263 case GFC_ISYM_MAXVAL
:
5264 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
5267 case GFC_ISYM_MERGE
:
5268 gfc_conv_intrinsic_merge (se
, expr
);
5272 if (expr
->ts
.type
== BT_CHARACTER
)
5273 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
5275 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
5278 case GFC_ISYM_MINLOC
:
5279 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
5282 case GFC_ISYM_MINVAL
:
5283 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
5286 case GFC_ISYM_NEAREST
:
5287 gfc_conv_intrinsic_nearest (se
, expr
);
5291 gfc_conv_intrinsic_not (se
, expr
);
5295 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
5298 case GFC_ISYM_PRESENT
:
5299 gfc_conv_intrinsic_present (se
, expr
);
5302 case GFC_ISYM_PRODUCT
:
5303 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
5306 case GFC_ISYM_RRSPACING
:
5307 gfc_conv_intrinsic_rrspacing (se
, expr
);
5310 case GFC_ISYM_SET_EXPONENT
:
5311 gfc_conv_intrinsic_set_exponent (se
, expr
);
5314 case GFC_ISYM_SCALE
:
5315 gfc_conv_intrinsic_scale (se
, expr
);
5319 gfc_conv_intrinsic_sign (se
, expr
);
5323 gfc_conv_intrinsic_size (se
, expr
);
5326 case GFC_ISYM_SIZEOF
:
5327 case GFC_ISYM_C_SIZEOF
:
5328 gfc_conv_intrinsic_sizeof (se
, expr
);
5331 case GFC_ISYM_STORAGE_SIZE
:
5332 gfc_conv_intrinsic_storage_size (se
, expr
);
5335 case GFC_ISYM_SPACING
:
5336 gfc_conv_intrinsic_spacing (se
, expr
);
5340 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
5343 case GFC_ISYM_TRANSFER
:
5344 if (se
->ss
&& se
->ss
->useflags
)
5346 /* Access the previously obtained result. */
5347 gfc_conv_tmp_array_ref (se
);
5348 gfc_advance_se_ss_chain (se
);
5351 gfc_conv_intrinsic_transfer (se
, expr
);
5354 case GFC_ISYM_TTYNAM
:
5355 gfc_conv_intrinsic_ttynam (se
, expr
);
5358 case GFC_ISYM_UBOUND
:
5359 gfc_conv_intrinsic_bound (se
, expr
, 1);
5363 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
5367 gfc_conv_intrinsic_loc (se
, expr
);
5370 case GFC_ISYM_ACCESS
:
5371 case GFC_ISYM_CHDIR
:
5372 case GFC_ISYM_CHMOD
:
5373 case GFC_ISYM_DTIME
:
5374 case GFC_ISYM_ETIME
:
5375 case GFC_ISYM_EXTENDS_TYPE_OF
:
5377 case GFC_ISYM_FGETC
:
5380 case GFC_ISYM_FPUTC
:
5381 case GFC_ISYM_FSTAT
:
5382 case GFC_ISYM_FTELL
:
5383 case GFC_ISYM_GETCWD
:
5384 case GFC_ISYM_GETGID
:
5385 case GFC_ISYM_GETPID
:
5386 case GFC_ISYM_GETUID
:
5387 case GFC_ISYM_HOSTNM
:
5389 case GFC_ISYM_IERRNO
:
5390 case GFC_ISYM_IRAND
:
5391 case GFC_ISYM_ISATTY
:
5393 case GFC_ISYM_LSTAT
:
5394 case GFC_ISYM_MALLOC
:
5395 case GFC_ISYM_MATMUL
:
5396 case GFC_ISYM_MCLOCK
:
5397 case GFC_ISYM_MCLOCK8
:
5399 case GFC_ISYM_RENAME
:
5400 case GFC_ISYM_SECOND
:
5401 case GFC_ISYM_SECNDS
:
5402 case GFC_ISYM_SIGNAL
:
5404 case GFC_ISYM_SYMLNK
:
5405 case GFC_ISYM_SYSTEM
:
5407 case GFC_ISYM_TIME8
:
5408 case GFC_ISYM_UMASK
:
5409 case GFC_ISYM_UNLINK
:
5410 gfc_conv_intrinsic_funcall (se
, expr
);
5413 case GFC_ISYM_EOSHIFT
:
5415 case GFC_ISYM_RESHAPE
:
5416 /* For those, expr->rank should always be >0 and thus the if above the
5417 switch should have matched. */
5422 gfc_conv_intrinsic_lib_function (se
, expr
);
5428 /* This generates code to execute before entering the scalarization loop.
5429 Currently does nothing. */
5432 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
5434 switch (ss
->expr
->value
.function
.isym
->id
)
5436 case GFC_ISYM_UBOUND
:
5437 case GFC_ISYM_LBOUND
:
5446 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5447 inside the scalarization loop. */
5450 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
5454 /* The two argument version returns a scalar. */
5455 if (expr
->value
.function
.actual
->next
->expr
)
5458 newss
= gfc_get_ss ();
5459 newss
->type
= GFC_SS_INTRINSIC
;
5462 newss
->data
.info
.dimen
= 1;
5468 /* Walk an intrinsic array libcall. */
5471 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
5475 gcc_assert (expr
->rank
> 0);
5477 newss
= gfc_get_ss ();
5478 newss
->type
= GFC_SS_FUNCTION
;
5481 newss
->data
.info
.dimen
= expr
->rank
;
5487 /* Returns nonzero if the specified intrinsic function call maps directly to
5488 an external library call. Should only be used for functions that return
5492 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
5494 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
5495 gcc_assert (expr
->rank
> 0);
5497 switch (expr
->value
.function
.isym
->id
)
5501 case GFC_ISYM_COUNT
:
5502 case GFC_ISYM_MATMUL
:
5503 case GFC_ISYM_MAXLOC
:
5504 case GFC_ISYM_MAXVAL
:
5505 case GFC_ISYM_MINLOC
:
5506 case GFC_ISYM_MINVAL
:
5507 case GFC_ISYM_PRODUCT
:
5509 case GFC_ISYM_SHAPE
:
5510 case GFC_ISYM_SPREAD
:
5511 case GFC_ISYM_TRANSPOSE
:
5512 /* Ignore absent optional parameters. */
5515 case GFC_ISYM_RESHAPE
:
5516 case GFC_ISYM_CSHIFT
:
5517 case GFC_ISYM_EOSHIFT
:
5519 case GFC_ISYM_UNPACK
:
5520 /* Pass absent optional parameters. */
5528 /* Walk an intrinsic function. */
5530 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
5531 gfc_intrinsic_sym
* isym
)
5535 if (isym
->elemental
)
5536 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
5538 if (expr
->rank
== 0)
5541 if (gfc_is_intrinsic_libcall (expr
))
5542 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5544 /* Special cases. */
5547 case GFC_ISYM_LBOUND
:
5548 case GFC_ISYM_UBOUND
:
5549 return gfc_walk_intrinsic_bound (ss
, expr
);
5551 case GFC_ISYM_TRANSFER
:
5552 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5555 /* This probably meant someone forgot to add an intrinsic to the above
5556 list(s) when they implemented it, or something's gone horribly
5562 #include "gt-fortran-trans-intrinsic.h"