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
= XALLOCAVEC (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
= XALLOCAVEC (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
= chainon (argtypes
, void_list_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
= XALLOCAVEC (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
= XALLOCAVEC (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
= XALLOCAVEC (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
= XALLOCAVEC (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
= XALLOCAVEC (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
= XALLOCAVEC (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
= XALLOCAVEC (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 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
1570 /* Generate a call to an external intrinsic function. */
1572 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1575 VEC(tree
,gc
) *append_args
;
1577 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1580 gcc_assert (expr
->rank
> 0);
1582 gcc_assert (expr
->rank
== 0);
1584 sym
= gfc_get_symbol_for_expr (expr
);
1586 /* Calls to libgfortran_matmul need to be appended special arguments,
1587 to be able to call the BLAS ?gemm functions if required and possible. */
1589 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1590 && sym
->ts
.type
!= BT_LOGICAL
)
1592 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1594 if (gfc_option
.flag_external_blas
1595 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1596 && (sym
->ts
.kind
== gfc_default_real_kind
1597 || sym
->ts
.kind
== gfc_default_double_kind
))
1601 if (sym
->ts
.type
== BT_REAL
)
1603 if (sym
->ts
.kind
== gfc_default_real_kind
)
1604 gemm_fndecl
= gfor_fndecl_sgemm
;
1606 gemm_fndecl
= gfor_fndecl_dgemm
;
1610 if (sym
->ts
.kind
== gfc_default_real_kind
)
1611 gemm_fndecl
= gfor_fndecl_cgemm
;
1613 gemm_fndecl
= gfor_fndecl_zgemm
;
1616 append_args
= VEC_alloc (tree
, gc
, 3);
1617 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 1));
1618 VEC_quick_push (tree
, append_args
,
1619 build_int_cst (cint
, gfc_option
.blas_matmul_limit
));
1620 VEC_quick_push (tree
, append_args
,
1621 gfc_build_addr_expr (NULL_TREE
, gemm_fndecl
));
1625 append_args
= VEC_alloc (tree
, gc
, 3);
1626 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
1627 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
1628 VEC_quick_push (tree
, append_args
, null_pointer_node
);
1632 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
1637 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1657 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1666 gfc_actual_arglist
*actual
;
1673 gfc_conv_intrinsic_funcall (se
, expr
);
1677 actual
= expr
->value
.function
.actual
;
1678 type
= gfc_typenode_for_spec (&expr
->ts
);
1679 /* Initialize the result. */
1680 resvar
= gfc_create_var (type
, "test");
1682 tmp
= convert (type
, boolean_true_node
);
1684 tmp
= convert (type
, boolean_false_node
);
1685 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1687 /* Walk the arguments. */
1688 arrayss
= gfc_walk_expr (actual
->expr
);
1689 gcc_assert (arrayss
!= gfc_ss_terminator
);
1691 /* Initialize the scalarizer. */
1692 gfc_init_loopinfo (&loop
);
1693 exit_label
= gfc_build_label_decl (NULL_TREE
);
1694 TREE_USED (exit_label
) = 1;
1695 gfc_add_ss_to_loop (&loop
, arrayss
);
1697 /* Initialize the loop. */
1698 gfc_conv_ss_startstride (&loop
);
1699 gfc_conv_loop_setup (&loop
, &expr
->where
);
1701 gfc_mark_ss_chain_used (arrayss
, 1);
1702 /* Generate the loop body. */
1703 gfc_start_scalarized_body (&loop
, &body
);
1705 /* If the condition matches then set the return value. */
1706 gfc_start_block (&block
);
1708 tmp
= convert (type
, boolean_false_node
);
1710 tmp
= convert (type
, boolean_true_node
);
1711 gfc_add_modify (&block
, resvar
, tmp
);
1713 /* And break out of the loop. */
1714 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1715 gfc_add_expr_to_block (&block
, tmp
);
1717 found
= gfc_finish_block (&block
);
1719 /* Check this element. */
1720 gfc_init_se (&arrayse
, NULL
);
1721 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1722 arrayse
.ss
= arrayss
;
1723 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1725 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1726 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1727 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1728 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
1729 gfc_add_expr_to_block (&body
, tmp
);
1730 gfc_add_block_to_block (&body
, &arrayse
.post
);
1732 gfc_trans_scalarizing_loops (&loop
, &body
);
1734 /* Add the exit label. */
1735 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1736 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1738 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1739 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1740 gfc_cleanup_loop (&loop
);
1745 /* COUNT(A) = Number of true elements in A. */
1747 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1754 gfc_actual_arglist
*actual
;
1760 gfc_conv_intrinsic_funcall (se
, expr
);
1764 actual
= expr
->value
.function
.actual
;
1766 type
= gfc_typenode_for_spec (&expr
->ts
);
1767 /* Initialize the result. */
1768 resvar
= gfc_create_var (type
, "count");
1769 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
1771 /* Walk the arguments. */
1772 arrayss
= gfc_walk_expr (actual
->expr
);
1773 gcc_assert (arrayss
!= gfc_ss_terminator
);
1775 /* Initialize the scalarizer. */
1776 gfc_init_loopinfo (&loop
);
1777 gfc_add_ss_to_loop (&loop
, arrayss
);
1779 /* Initialize the loop. */
1780 gfc_conv_ss_startstride (&loop
);
1781 gfc_conv_loop_setup (&loop
, &expr
->where
);
1783 gfc_mark_ss_chain_used (arrayss
, 1);
1784 /* Generate the loop body. */
1785 gfc_start_scalarized_body (&loop
, &body
);
1787 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (resvar
),
1788 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
1789 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1791 gfc_init_se (&arrayse
, NULL
);
1792 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1793 arrayse
.ss
= arrayss
;
1794 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1795 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
1796 build_empty_stmt (input_location
));
1798 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1799 gfc_add_expr_to_block (&body
, tmp
);
1800 gfc_add_block_to_block (&body
, &arrayse
.post
);
1802 gfc_trans_scalarizing_loops (&loop
, &body
);
1804 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1805 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1806 gfc_cleanup_loop (&loop
);
1811 /* Inline implementation of the sum and product intrinsics. */
1813 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1821 gfc_actual_arglist
*actual
;
1826 gfc_expr
*arrayexpr
;
1831 gfc_conv_intrinsic_funcall (se
, expr
);
1835 type
= gfc_typenode_for_spec (&expr
->ts
);
1836 /* Initialize the result. */
1837 resvar
= gfc_create_var (type
, "val");
1838 if (op
== PLUS_EXPR
)
1839 tmp
= gfc_build_const (type
, integer_zero_node
);
1841 tmp
= gfc_build_const (type
, integer_one_node
);
1843 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1845 /* Walk the arguments. */
1846 actual
= expr
->value
.function
.actual
;
1847 arrayexpr
= actual
->expr
;
1848 arrayss
= gfc_walk_expr (arrayexpr
);
1849 gcc_assert (arrayss
!= gfc_ss_terminator
);
1851 actual
= actual
->next
->next
;
1852 gcc_assert (actual
);
1853 maskexpr
= actual
->expr
;
1854 if (maskexpr
&& maskexpr
->rank
!= 0)
1856 maskss
= gfc_walk_expr (maskexpr
);
1857 gcc_assert (maskss
!= gfc_ss_terminator
);
1862 /* Initialize the scalarizer. */
1863 gfc_init_loopinfo (&loop
);
1864 gfc_add_ss_to_loop (&loop
, arrayss
);
1866 gfc_add_ss_to_loop (&loop
, maskss
);
1868 /* Initialize the loop. */
1869 gfc_conv_ss_startstride (&loop
);
1870 gfc_conv_loop_setup (&loop
, &expr
->where
);
1872 gfc_mark_ss_chain_used (arrayss
, 1);
1874 gfc_mark_ss_chain_used (maskss
, 1);
1875 /* Generate the loop body. */
1876 gfc_start_scalarized_body (&loop
, &body
);
1878 /* If we have a mask, only add this element if the mask is set. */
1881 gfc_init_se (&maskse
, NULL
);
1882 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1884 gfc_conv_expr_val (&maskse
, maskexpr
);
1885 gfc_add_block_to_block (&body
, &maskse
.pre
);
1887 gfc_start_block (&block
);
1890 gfc_init_block (&block
);
1892 /* Do the actual summation/product. */
1893 gfc_init_se (&arrayse
, NULL
);
1894 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1895 arrayse
.ss
= arrayss
;
1896 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1897 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1899 tmp
= fold_build2 (op
, type
, resvar
, arrayse
.expr
);
1900 gfc_add_modify (&block
, resvar
, tmp
);
1901 gfc_add_block_to_block (&block
, &arrayse
.post
);
1905 /* We enclose the above in if (mask) {...} . */
1906 tmp
= gfc_finish_block (&block
);
1908 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
1909 build_empty_stmt (input_location
));
1912 tmp
= gfc_finish_block (&block
);
1913 gfc_add_expr_to_block (&body
, tmp
);
1915 gfc_trans_scalarizing_loops (&loop
, &body
);
1917 /* For a scalar mask, enclose the loop in an if statement. */
1918 if (maskexpr
&& maskss
== NULL
)
1920 gfc_init_se (&maskse
, NULL
);
1921 gfc_conv_expr_val (&maskse
, maskexpr
);
1922 gfc_init_block (&block
);
1923 gfc_add_block_to_block (&block
, &loop
.pre
);
1924 gfc_add_block_to_block (&block
, &loop
.post
);
1925 tmp
= gfc_finish_block (&block
);
1927 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
1928 build_empty_stmt (input_location
));
1929 gfc_add_expr_to_block (&block
, tmp
);
1930 gfc_add_block_to_block (&se
->pre
, &block
);
1934 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1935 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1938 gfc_cleanup_loop (&loop
);
1944 /* Inline implementation of the dot_product intrinsic. This function
1945 is based on gfc_conv_intrinsic_arith (the previous function). */
1947 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1955 gfc_actual_arglist
*actual
;
1956 gfc_ss
*arrayss1
, *arrayss2
;
1957 gfc_se arrayse1
, arrayse2
;
1958 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1960 type
= gfc_typenode_for_spec (&expr
->ts
);
1962 /* Initialize the result. */
1963 resvar
= gfc_create_var (type
, "val");
1964 if (expr
->ts
.type
== BT_LOGICAL
)
1965 tmp
= build_int_cst (type
, 0);
1967 tmp
= gfc_build_const (type
, integer_zero_node
);
1969 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1971 /* Walk argument #1. */
1972 actual
= expr
->value
.function
.actual
;
1973 arrayexpr1
= actual
->expr
;
1974 arrayss1
= gfc_walk_expr (arrayexpr1
);
1975 gcc_assert (arrayss1
!= gfc_ss_terminator
);
1977 /* Walk argument #2. */
1978 actual
= actual
->next
;
1979 arrayexpr2
= actual
->expr
;
1980 arrayss2
= gfc_walk_expr (arrayexpr2
);
1981 gcc_assert (arrayss2
!= gfc_ss_terminator
);
1983 /* Initialize the scalarizer. */
1984 gfc_init_loopinfo (&loop
);
1985 gfc_add_ss_to_loop (&loop
, arrayss1
);
1986 gfc_add_ss_to_loop (&loop
, arrayss2
);
1988 /* Initialize the loop. */
1989 gfc_conv_ss_startstride (&loop
);
1990 gfc_conv_loop_setup (&loop
, &expr
->where
);
1992 gfc_mark_ss_chain_used (arrayss1
, 1);
1993 gfc_mark_ss_chain_used (arrayss2
, 1);
1995 /* Generate the loop body. */
1996 gfc_start_scalarized_body (&loop
, &body
);
1997 gfc_init_block (&block
);
1999 /* Make the tree expression for [conjg(]array1[)]. */
2000 gfc_init_se (&arrayse1
, NULL
);
2001 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2002 arrayse1
.ss
= arrayss1
;
2003 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2004 if (expr
->ts
.type
== BT_COMPLEX
)
2005 arrayse1
.expr
= fold_build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
2006 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2008 /* Make the tree expression for array2. */
2009 gfc_init_se (&arrayse2
, NULL
);
2010 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2011 arrayse2
.ss
= arrayss2
;
2012 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2013 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2015 /* Do the actual product and sum. */
2016 if (expr
->ts
.type
== BT_LOGICAL
)
2018 tmp
= fold_build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2019 tmp
= fold_build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2023 tmp
= fold_build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2024 tmp
= fold_build2 (PLUS_EXPR
, type
, resvar
, tmp
);
2026 gfc_add_modify (&block
, resvar
, tmp
);
2028 /* Finish up the loop block and the loop. */
2029 tmp
= gfc_finish_block (&block
);
2030 gfc_add_expr_to_block (&body
, tmp
);
2032 gfc_trans_scalarizing_loops (&loop
, &body
);
2033 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2034 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2035 gfc_cleanup_loop (&loop
);
2041 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2042 we need to handle. For performance reasons we sometimes create two
2043 loops instead of one, where the second one is much simpler.
2044 Examples for minloc intrinsic:
2045 1) Result is an array, a call is generated
2046 2) Array mask is used and NaNs need to be supported:
2052 if (pos == 0) pos = S + (1 - from);
2053 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2060 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2064 3) NaNs need to be supported, but it is known at compile time or cheaply
2065 at runtime whether array is nonempty or not:
2070 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2073 if (from <= to) pos = 1;
2077 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2081 4) NaNs aren't supported, array mask is used:
2082 limit = infinities_supported ? Infinity : huge (limit);
2086 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2092 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2096 5) Same without array mask:
2097 limit = infinities_supported ? Infinity : huge (limit);
2098 pos = (from <= to) ? 1 : 0;
2101 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2104 For 3) and 5), if mask is scalar, this all goes into a conditional,
2105 setting pos = 0; in the else branch. */
2108 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2112 stmtblock_t ifblock
;
2113 stmtblock_t elseblock
;
2124 gfc_actual_arglist
*actual
;
2129 gfc_expr
*arrayexpr
;
2136 gfc_conv_intrinsic_funcall (se
, expr
);
2140 /* Initialize the result. */
2141 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2142 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2143 type
= gfc_typenode_for_spec (&expr
->ts
);
2145 /* Walk the arguments. */
2146 actual
= expr
->value
.function
.actual
;
2147 arrayexpr
= actual
->expr
;
2148 arrayss
= gfc_walk_expr (arrayexpr
);
2149 gcc_assert (arrayss
!= gfc_ss_terminator
);
2151 actual
= actual
->next
->next
;
2152 gcc_assert (actual
);
2153 maskexpr
= actual
->expr
;
2155 if (maskexpr
&& maskexpr
->rank
!= 0)
2157 maskss
= gfc_walk_expr (maskexpr
);
2158 gcc_assert (maskss
!= gfc_ss_terminator
);
2163 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
2165 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
2167 nonempty
= fold_build2 (GT_EXPR
, boolean_type_node
, nonempty
,
2168 gfc_index_zero_node
);
2173 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2174 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2175 switch (arrayexpr
->ts
.type
)
2178 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2180 REAL_VALUE_TYPE real
;
2182 tmp
= build_real (TREE_TYPE (limit
), real
);
2185 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
2186 arrayexpr
->ts
.kind
, 0);
2190 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2191 arrayexpr
->ts
.kind
);
2198 /* We start with the most negative possible value for MAXLOC, and the most
2199 positive possible value for MINLOC. The most negative possible value is
2200 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2201 possible value is HUGE in both cases. */
2203 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2204 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2205 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2206 build_int_cst (type
, 1));
2208 gfc_add_modify (&se
->pre
, limit
, tmp
);
2210 /* Initialize the scalarizer. */
2211 gfc_init_loopinfo (&loop
);
2212 gfc_add_ss_to_loop (&loop
, arrayss
);
2214 gfc_add_ss_to_loop (&loop
, maskss
);
2216 /* Initialize the loop. */
2217 gfc_conv_ss_startstride (&loop
);
2218 gfc_conv_loop_setup (&loop
, &expr
->where
);
2220 gcc_assert (loop
.dimen
== 1);
2221 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
2222 nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
, loop
.from
[0],
2227 /* Initialize the position to zero, following Fortran 2003. We are free
2228 to do this because Fortran 95 allows the result of an entirely false
2229 mask to be processor dependent. If we know at compile time the array
2230 is non-empty and no MASK is used, we can initialize to 1 to simplify
2232 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
2233 gfc_add_modify (&loop
.pre
, pos
,
2234 fold_build3 (COND_EXPR
, gfc_array_index_type
,
2235 nonempty
, gfc_index_one_node
,
2236 gfc_index_zero_node
));
2239 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
2240 lab1
= gfc_build_label_decl (NULL_TREE
);
2241 TREE_USED (lab1
) = 1;
2242 lab2
= gfc_build_label_decl (NULL_TREE
);
2243 TREE_USED (lab2
) = 1;
2246 gfc_mark_ss_chain_used (arrayss
, 1);
2248 gfc_mark_ss_chain_used (maskss
, 1);
2249 /* Generate the loop body. */
2250 gfc_start_scalarized_body (&loop
, &body
);
2252 /* If we have a mask, only check this element if the mask is set. */
2255 gfc_init_se (&maskse
, NULL
);
2256 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2258 gfc_conv_expr_val (&maskse
, maskexpr
);
2259 gfc_add_block_to_block (&body
, &maskse
.pre
);
2261 gfc_start_block (&block
);
2264 gfc_init_block (&block
);
2266 /* Compare with the current limit. */
2267 gfc_init_se (&arrayse
, NULL
);
2268 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2269 arrayse
.ss
= arrayss
;
2270 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2271 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2273 /* We do the following if this is a more extreme value. */
2274 gfc_start_block (&ifblock
);
2276 /* Assign the value to the limit... */
2277 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2279 /* Remember where we are. An offset must be added to the loop
2280 counter to obtain the required position. */
2282 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2283 gfc_index_one_node
, loop
.from
[0]);
2285 tmp
= gfc_index_one_node
;
2287 gfc_add_modify (&block
, offset
, tmp
);
2289 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
2291 stmtblock_t ifblock2
;
2294 gfc_start_block (&ifblock2
);
2295 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2296 loop
.loopvar
[0], offset
);
2297 gfc_add_modify (&ifblock2
, pos
, tmp
);
2298 ifbody2
= gfc_finish_block (&ifblock2
);
2299 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, pos
,
2300 gfc_index_zero_node
);
2301 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
2302 build_empty_stmt (input_location
));
2303 gfc_add_expr_to_block (&block
, tmp
);
2306 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2307 loop
.loopvar
[0], offset
);
2308 gfc_add_modify (&ifblock
, pos
, tmp
);
2311 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
2313 ifbody
= gfc_finish_block (&ifblock
);
2315 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
2318 cond
= fold_build2 (op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
2319 boolean_type_node
, arrayse
.expr
, limit
);
2321 cond
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2323 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
2324 build_empty_stmt (input_location
));
2326 gfc_add_expr_to_block (&block
, ifbody
);
2330 /* We enclose the above in if (mask) {...}. */
2331 tmp
= gfc_finish_block (&block
);
2333 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2334 build_empty_stmt (input_location
));
2337 tmp
= gfc_finish_block (&block
);
2338 gfc_add_expr_to_block (&body
, tmp
);
2342 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
2344 if (HONOR_NANS (DECL_MODE (limit
)))
2346 if (nonempty
!= NULL
)
2348 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
2349 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
2350 build_empty_stmt (input_location
));
2351 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
2355 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
2356 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
2357 gfc_start_block (&body
);
2359 /* If we have a mask, only check this element if the mask is set. */
2362 gfc_init_se (&maskse
, NULL
);
2363 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2365 gfc_conv_expr_val (&maskse
, maskexpr
);
2366 gfc_add_block_to_block (&body
, &maskse
.pre
);
2368 gfc_start_block (&block
);
2371 gfc_init_block (&block
);
2373 /* Compare with the current limit. */
2374 gfc_init_se (&arrayse
, NULL
);
2375 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2376 arrayse
.ss
= arrayss
;
2377 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2378 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2380 /* We do the following if this is a more extreme value. */
2381 gfc_start_block (&ifblock
);
2383 /* Assign the value to the limit... */
2384 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2386 /* Remember where we are. An offset must be added to the loop
2387 counter to obtain the required position. */
2389 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2390 gfc_index_one_node
, loop
.from
[0]);
2392 tmp
= gfc_index_one_node
;
2394 gfc_add_modify (&block
, offset
, tmp
);
2396 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2397 loop
.loopvar
[0], offset
);
2398 gfc_add_modify (&ifblock
, pos
, tmp
);
2400 ifbody
= gfc_finish_block (&ifblock
);
2402 cond
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2404 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
2405 build_empty_stmt (input_location
));
2406 gfc_add_expr_to_block (&block
, tmp
);
2410 /* We enclose the above in if (mask) {...}. */
2411 tmp
= gfc_finish_block (&block
);
2413 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2414 build_empty_stmt (input_location
));
2417 tmp
= gfc_finish_block (&block
);
2418 gfc_add_expr_to_block (&body
, tmp
);
2419 /* Avoid initializing loopvar[0] again, it should be left where
2420 it finished by the first loop. */
2421 loop
.from
[0] = loop
.loopvar
[0];
2424 gfc_trans_scalarizing_loops (&loop
, &body
);
2427 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
2429 /* For a scalar mask, enclose the loop in an if statement. */
2430 if (maskexpr
&& maskss
== NULL
)
2432 gfc_init_se (&maskse
, NULL
);
2433 gfc_conv_expr_val (&maskse
, maskexpr
);
2434 gfc_init_block (&block
);
2435 gfc_add_block_to_block (&block
, &loop
.pre
);
2436 gfc_add_block_to_block (&block
, &loop
.post
);
2437 tmp
= gfc_finish_block (&block
);
2439 /* For the else part of the scalar mask, just initialize
2440 the pos variable the same way as above. */
2442 gfc_init_block (&elseblock
);
2443 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
2444 elsetmp
= gfc_finish_block (&elseblock
);
2446 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2447 gfc_add_expr_to_block (&block
, tmp
);
2448 gfc_add_block_to_block (&se
->pre
, &block
);
2452 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2453 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2455 gfc_cleanup_loop (&loop
);
2457 se
->expr
= convert (type
, pos
);
2460 /* Emit code for minval or maxval intrinsic. There are many different cases
2461 we need to handle. For performance reasons we sometimes create two
2462 loops instead of one, where the second one is much simpler.
2463 Examples for minval intrinsic:
2464 1) Result is an array, a call is generated
2465 2) Array mask is used and NaNs need to be supported, rank 1:
2470 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2473 limit = nonempty ? NaN : huge (limit);
2475 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2476 3) NaNs need to be supported, but it is known at compile time or cheaply
2477 at runtime whether array is nonempty or not, rank 1:
2480 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2481 limit = (from <= to) ? NaN : huge (limit);
2483 while (S <= to) { limit = min (a[S], limit); S++; }
2484 4) Array mask is used and NaNs need to be supported, rank > 1:
2493 if (fast) limit = min (a[S1][S2], limit);
2496 if (a[S1][S2] <= limit) {
2507 limit = nonempty ? NaN : huge (limit);
2508 5) NaNs need to be supported, but it is known at compile time or cheaply
2509 at runtime whether array is nonempty or not, rank > 1:
2516 if (fast) limit = min (a[S1][S2], limit);
2518 if (a[S1][S2] <= limit) {
2528 limit = (nonempty_array) ? NaN : huge (limit);
2529 6) NaNs aren't supported, but infinities are. Array mask is used:
2534 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2537 limit = nonempty ? limit : huge (limit);
2538 7) Same without array mask:
2541 while (S <= to) { limit = min (a[S], limit); S++; }
2542 limit = (from <= to) ? limit : huge (limit);
2543 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2544 limit = huge (limit);
2546 while (S <= to) { limit = min (a[S], limit); S++); }
2548 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2549 with array mask instead).
2550 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2551 setting limit = huge (limit); in the else branch. */
2554 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2564 tree huge_cst
= NULL
, nan_cst
= NULL
;
2566 stmtblock_t block
, block2
;
2568 gfc_actual_arglist
*actual
;
2573 gfc_expr
*arrayexpr
;
2579 gfc_conv_intrinsic_funcall (se
, expr
);
2583 type
= gfc_typenode_for_spec (&expr
->ts
);
2584 /* Initialize the result. */
2585 limit
= gfc_create_var (type
, "limit");
2586 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2587 switch (expr
->ts
.type
)
2590 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
2592 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2594 REAL_VALUE_TYPE real
;
2596 tmp
= build_real (type
, real
);
2600 if (HONOR_NANS (DECL_MODE (limit
)))
2602 REAL_VALUE_TYPE real
;
2603 real_nan (&real
, "", 1, DECL_MODE (limit
));
2604 nan_cst
= build_real (type
, real
);
2609 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2616 /* We start with the most negative possible value for MAXVAL, and the most
2617 positive possible value for MINVAL. The most negative possible value is
2618 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2619 possible value is HUGE in both cases. */
2622 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2624 huge_cst
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (huge_cst
), huge_cst
);
2627 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2628 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
),
2629 tmp
, build_int_cst (type
, 1));
2631 gfc_add_modify (&se
->pre
, limit
, tmp
);
2633 /* Walk the arguments. */
2634 actual
= expr
->value
.function
.actual
;
2635 arrayexpr
= actual
->expr
;
2636 arrayss
= gfc_walk_expr (arrayexpr
);
2637 gcc_assert (arrayss
!= gfc_ss_terminator
);
2639 actual
= actual
->next
->next
;
2640 gcc_assert (actual
);
2641 maskexpr
= actual
->expr
;
2643 if (maskexpr
&& maskexpr
->rank
!= 0)
2645 maskss
= gfc_walk_expr (maskexpr
);
2646 gcc_assert (maskss
!= gfc_ss_terminator
);
2651 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
2653 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
2655 nonempty
= fold_build2 (GT_EXPR
, boolean_type_node
, nonempty
,
2656 gfc_index_zero_node
);
2661 /* Initialize the scalarizer. */
2662 gfc_init_loopinfo (&loop
);
2663 gfc_add_ss_to_loop (&loop
, arrayss
);
2665 gfc_add_ss_to_loop (&loop
, maskss
);
2667 /* Initialize the loop. */
2668 gfc_conv_ss_startstride (&loop
);
2669 gfc_conv_loop_setup (&loop
, &expr
->where
);
2671 if (nonempty
== NULL
&& maskss
== NULL
2672 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
2673 nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
, loop
.from
[0],
2675 nonempty_var
= NULL
;
2676 if (nonempty
== NULL
2677 && (HONOR_INFINITIES (DECL_MODE (limit
))
2678 || HONOR_NANS (DECL_MODE (limit
))))
2680 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
2681 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
2682 nonempty
= nonempty_var
;
2686 if (HONOR_NANS (DECL_MODE (limit
)))
2688 if (loop
.dimen
== 1)
2690 lab
= gfc_build_label_decl (NULL_TREE
);
2691 TREE_USED (lab
) = 1;
2695 fast
= gfc_create_var (boolean_type_node
, "fast");
2696 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
2700 gfc_mark_ss_chain_used (arrayss
, 1);
2702 gfc_mark_ss_chain_used (maskss
, 1);
2703 /* Generate the loop body. */
2704 gfc_start_scalarized_body (&loop
, &body
);
2706 /* If we have a mask, only add this element if the mask is set. */
2709 gfc_init_se (&maskse
, NULL
);
2710 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2712 gfc_conv_expr_val (&maskse
, maskexpr
);
2713 gfc_add_block_to_block (&body
, &maskse
.pre
);
2715 gfc_start_block (&block
);
2718 gfc_init_block (&block
);
2720 /* Compare with the current limit. */
2721 gfc_init_se (&arrayse
, NULL
);
2722 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2723 arrayse
.ss
= arrayss
;
2724 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2725 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2727 gfc_init_block (&block2
);
2730 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
2732 if (HONOR_NANS (DECL_MODE (limit
)))
2734 tmp
= fold_build2 (op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
2735 boolean_type_node
, arrayse
.expr
, limit
);
2737 ifbody
= build1_v (GOTO_EXPR
, lab
);
2740 stmtblock_t ifblock
;
2742 gfc_init_block (&ifblock
);
2743 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2744 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
2745 ifbody
= gfc_finish_block (&ifblock
);
2747 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
2748 build_empty_stmt (input_location
));
2749 gfc_add_expr_to_block (&block2
, tmp
);
2753 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2755 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
2757 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2758 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2759 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
2760 build_empty_stmt (input_location
));
2761 gfc_add_expr_to_block (&block2
, tmp
);
2765 tmp
= fold_build2 (op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
2766 type
, arrayse
.expr
, limit
);
2767 gfc_add_modify (&block2
, limit
, tmp
);
2773 tree elsebody
= gfc_finish_block (&block2
);
2775 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2777 if (HONOR_NANS (DECL_MODE (limit
))
2778 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
2780 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2781 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2782 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
2783 build_empty_stmt (input_location
));
2787 tmp
= fold_build2 (op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
2788 type
, arrayse
.expr
, limit
);
2789 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
2791 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
2792 gfc_add_expr_to_block (&block
, tmp
);
2795 gfc_add_block_to_block (&block
, &block2
);
2797 gfc_add_block_to_block (&block
, &arrayse
.post
);
2799 tmp
= gfc_finish_block (&block
);
2801 /* We enclose the above in if (mask) {...}. */
2802 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2803 build_empty_stmt (input_location
));
2804 gfc_add_expr_to_block (&body
, tmp
);
2808 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
2810 tmp
= fold_build3 (COND_EXPR
, type
, nonempty
, nan_cst
, huge_cst
);
2811 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
2812 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
2814 gfc_start_block (&body
);
2816 /* If we have a mask, only add this element if the mask is set. */
2819 gfc_init_se (&maskse
, NULL
);
2820 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2822 gfc_conv_expr_val (&maskse
, maskexpr
);
2823 gfc_add_block_to_block (&body
, &maskse
.pre
);
2825 gfc_start_block (&block
);
2828 gfc_init_block (&block
);
2830 /* Compare with the current limit. */
2831 gfc_init_se (&arrayse
, NULL
);
2832 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2833 arrayse
.ss
= arrayss
;
2834 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2835 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2837 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2839 if (HONOR_NANS (DECL_MODE (limit
))
2840 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
2842 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2843 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2844 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
2845 build_empty_stmt (input_location
));
2846 gfc_add_expr_to_block (&block
, tmp
);
2850 tmp
= fold_build2 (op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
2851 type
, arrayse
.expr
, limit
);
2852 gfc_add_modify (&block
, limit
, tmp
);
2855 gfc_add_block_to_block (&block
, &arrayse
.post
);
2857 tmp
= gfc_finish_block (&block
);
2859 /* We enclose the above in if (mask) {...}. */
2860 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2861 build_empty_stmt (input_location
));
2862 gfc_add_expr_to_block (&body
, tmp
);
2863 /* Avoid initializing loopvar[0] again, it should be left where
2864 it finished by the first loop. */
2865 loop
.from
[0] = loop
.loopvar
[0];
2867 gfc_trans_scalarizing_loops (&loop
, &body
);
2871 tmp
= fold_build3 (COND_EXPR
, type
, nonempty
, nan_cst
, huge_cst
);
2872 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
2873 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
2875 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2877 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
2879 tmp
= fold_build3 (COND_EXPR
, type
, nonempty
, limit
, huge_cst
);
2880 gfc_add_modify (&loop
.pre
, limit
, tmp
);
2883 /* For a scalar mask, enclose the loop in an if statement. */
2884 if (maskexpr
&& maskss
== NULL
)
2888 gfc_init_se (&maskse
, NULL
);
2889 gfc_conv_expr_val (&maskse
, maskexpr
);
2890 gfc_init_block (&block
);
2891 gfc_add_block_to_block (&block
, &loop
.pre
);
2892 gfc_add_block_to_block (&block
, &loop
.post
);
2893 tmp
= gfc_finish_block (&block
);
2895 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2896 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
2898 else_stmt
= build_empty_stmt (input_location
);
2899 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
2900 gfc_add_expr_to_block (&block
, tmp
);
2901 gfc_add_block_to_block (&se
->pre
, &block
);
2905 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2906 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2909 gfc_cleanup_loop (&loop
);
2914 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2916 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2922 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2923 type
= TREE_TYPE (args
[0]);
2925 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2926 tmp
= fold_build2 (BIT_AND_EXPR
, type
, args
[0], tmp
);
2927 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2928 build_int_cst (type
, 0));
2929 type
= gfc_typenode_for_spec (&expr
->ts
);
2930 se
->expr
= convert (type
, tmp
);
2933 /* Generate code to perform the specified operation. */
2935 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2939 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2940 se
->expr
= fold_build2 (op
, TREE_TYPE (args
[0]), args
[0], args
[1]);
2945 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2949 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2950 se
->expr
= fold_build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2953 /* Set or clear a single bit. */
2955 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2962 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2963 type
= TREE_TYPE (args
[0]);
2965 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2971 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2973 se
->expr
= fold_build2 (op
, type
, args
[0], tmp
);
2976 /* Extract a sequence of bits.
2977 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2979 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2986 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2987 type
= TREE_TYPE (args
[0]);
2989 mask
= build_int_cst (type
, -1);
2990 mask
= fold_build2 (LSHIFT_EXPR
, type
, mask
, args
[2]);
2991 mask
= fold_build1 (BIT_NOT_EXPR
, type
, mask
);
2993 tmp
= fold_build2 (RSHIFT_EXPR
, type
, args
[0], args
[1]);
2995 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2998 /* RSHIFT (I, SHIFT) = I >> SHIFT
2999 LSHIFT (I, SHIFT) = I << SHIFT */
3001 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
3005 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3007 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
3008 TREE_TYPE (args
[0]), args
[0], args
[1]);
3011 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3013 : ((shift >= 0) ? i << shift : i >> -shift)
3014 where all shifts are logical shifts. */
3016 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
3028 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3029 type
= TREE_TYPE (args
[0]);
3030 utype
= unsigned_type_for (type
);
3032 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (args
[1]), args
[1]);
3034 /* Left shift if positive. */
3035 lshift
= fold_build2 (LSHIFT_EXPR
, type
, args
[0], width
);
3037 /* Right shift if negative.
3038 We convert to an unsigned type because we want a logical shift.
3039 The standard doesn't define the case of shifting negative
3040 numbers, and we try to be compatible with other compilers, most
3041 notably g77, here. */
3042 rshift
= fold_convert (type
, fold_build2 (RSHIFT_EXPR
, utype
,
3043 convert (utype
, args
[0]), width
));
3045 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, args
[1],
3046 build_int_cst (TREE_TYPE (args
[1]), 0));
3047 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
3049 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3050 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3052 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
3053 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
3055 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
3056 build_int_cst (type
, 0), tmp
);
3060 /* Circular shift. AKA rotate or barrel shift. */
3063 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
3071 unsigned int num_args
;
3073 num_args
= gfc_intrinsic_argument_list_length (expr
);
3074 args
= XALLOCAVEC (tree
, num_args
);
3076 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3080 /* Use a library function for the 3 parameter version. */
3081 tree int4type
= gfc_get_int_type (4);
3083 type
= TREE_TYPE (args
[0]);
3084 /* We convert the first argument to at least 4 bytes, and
3085 convert back afterwards. This removes the need for library
3086 functions for all argument sizes, and function will be
3087 aligned to at least 32 bits, so there's no loss. */
3088 if (expr
->ts
.kind
< 4)
3089 args
[0] = convert (int4type
, args
[0]);
3091 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3092 need loads of library functions. They cannot have values >
3093 BIT_SIZE (I) so the conversion is safe. */
3094 args
[1] = convert (int4type
, args
[1]);
3095 args
[2] = convert (int4type
, args
[2]);
3097 switch (expr
->ts
.kind
)
3102 tmp
= gfor_fndecl_math_ishftc4
;
3105 tmp
= gfor_fndecl_math_ishftc8
;
3108 tmp
= gfor_fndecl_math_ishftc16
;
3113 se
->expr
= build_call_expr_loc (input_location
,
3114 tmp
, 3, args
[0], args
[1], args
[2]);
3115 /* Convert the result back to the original type, if we extended
3116 the first argument's width above. */
3117 if (expr
->ts
.kind
< 4)
3118 se
->expr
= convert (type
, se
->expr
);
3122 type
= TREE_TYPE (args
[0]);
3124 /* Rotate left if positive. */
3125 lrot
= fold_build2 (LROTATE_EXPR
, type
, args
[0], args
[1]);
3127 /* Rotate right if negative. */
3128 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (args
[1]), args
[1]);
3129 rrot
= fold_build2 (RROTATE_EXPR
, type
, args
[0], tmp
);
3131 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
3132 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, args
[1], zero
);
3133 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
3135 /* Do nothing if shift == 0. */
3136 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
3137 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, args
[0], rrot
);
3140 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3141 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3143 The conditional expression is necessary because the result of LEADZ(0)
3144 is defined, but the result of __builtin_clz(0) is undefined for most
3147 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3148 difference in bit size between the argument of LEADZ and the C int. */
3151 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
3163 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3164 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3166 /* Which variant of __builtin_clz* should we call? */
3167 if (argsize
<= INT_TYPE_SIZE
)
3169 arg_type
= unsigned_type_node
;
3170 func
= built_in_decls
[BUILT_IN_CLZ
];
3172 else if (argsize
<= LONG_TYPE_SIZE
)
3174 arg_type
= long_unsigned_type_node
;
3175 func
= built_in_decls
[BUILT_IN_CLZL
];
3177 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3179 arg_type
= long_long_unsigned_type_node
;
3180 func
= built_in_decls
[BUILT_IN_CLZLL
];
3184 gcc_assert (argsize
== 128);
3185 arg_type
= gfc_build_uint_type (argsize
);
3186 func
= gfor_fndecl_clz128
;
3189 /* Convert the actual argument twice: first, to the unsigned type of the
3190 same size; then, to the proper argument type for the built-in
3191 function. But the return type is of the default INTEGER kind. */
3192 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3193 arg
= fold_convert (arg_type
, arg
);
3194 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3196 /* Compute LEADZ for the case i .ne. 0. */
3197 s
= TYPE_PRECISION (arg_type
) - argsize
;
3198 tmp
= fold_convert (result_type
, build_call_expr (func
, 1, arg
));
3199 leadz
= fold_build2 (MINUS_EXPR
, result_type
,
3200 tmp
, build_int_cst (result_type
, s
));
3202 /* Build BIT_SIZE. */
3203 bit_size
= build_int_cst (result_type
, argsize
);
3205 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3206 arg
, build_int_cst (arg_type
, 0));
3207 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, leadz
);
3210 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3212 The conditional expression is necessary because the result of TRAILZ(0)
3213 is defined, but the result of __builtin_ctz(0) is undefined for most
3217 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
3228 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3229 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3231 /* Which variant of __builtin_ctz* should we call? */
3232 if (argsize
<= INT_TYPE_SIZE
)
3234 arg_type
= unsigned_type_node
;
3235 func
= built_in_decls
[BUILT_IN_CTZ
];
3237 else if (argsize
<= LONG_TYPE_SIZE
)
3239 arg_type
= long_unsigned_type_node
;
3240 func
= built_in_decls
[BUILT_IN_CTZL
];
3242 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3244 arg_type
= long_long_unsigned_type_node
;
3245 func
= built_in_decls
[BUILT_IN_CTZLL
];
3249 gcc_assert (argsize
== 128);
3250 arg_type
= gfc_build_uint_type (argsize
);
3251 func
= gfor_fndecl_ctz128
;
3254 /* Convert the actual argument twice: first, to the unsigned type of the
3255 same size; then, to the proper argument type for the built-in
3256 function. But the return type is of the default INTEGER kind. */
3257 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3258 arg
= fold_convert (arg_type
, arg
);
3259 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3261 /* Compute TRAILZ for the case i .ne. 0. */
3262 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
3265 /* Build BIT_SIZE. */
3266 bit_size
= build_int_cst (result_type
, argsize
);
3268 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3269 arg
, build_int_cst (arg_type
, 0));
3270 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, trailz
);
3273 /* Process an intrinsic with unspecified argument-types that has an optional
3274 argument (which could be of type character), e.g. EOSHIFT. For those, we
3275 need to append the string length of the optional argument if it is not
3276 present and the type is really character.
3277 primary specifies the position (starting at 1) of the non-optional argument
3278 specifying the type and optional gives the position of the optional
3279 argument in the arglist. */
3282 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
3283 unsigned primary
, unsigned optional
)
3285 gfc_actual_arglist
* prim_arg
;
3286 gfc_actual_arglist
* opt_arg
;
3288 gfc_actual_arglist
* arg
;
3290 VEC(tree
,gc
) *append_args
;
3292 /* Find the two arguments given as position. */
3296 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3300 if (cur_pos
== primary
)
3302 if (cur_pos
== optional
)
3305 if (cur_pos
>= primary
&& cur_pos
>= optional
)
3308 gcc_assert (prim_arg
);
3309 gcc_assert (prim_arg
->expr
);
3310 gcc_assert (opt_arg
);
3312 /* If we do have type CHARACTER and the optional argument is really absent,
3313 append a dummy 0 as string length. */
3315 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
3319 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
3320 append_args
= VEC_alloc (tree
, gc
, 1);
3321 VEC_quick_push (tree
, append_args
, dummy
);
3324 /* Build the call itself. */
3325 sym
= gfc_get_symbol_for_expr (expr
);
3326 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3332 /* The length of a character string. */
3334 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
3344 gcc_assert (!se
->ss
);
3346 arg
= expr
->value
.function
.actual
->expr
;
3348 type
= gfc_typenode_for_spec (&expr
->ts
);
3349 switch (arg
->expr_type
)
3352 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
3356 /* Obtain the string length from the function used by
3357 trans-array.c(gfc_trans_array_constructor). */
3359 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
3363 if (arg
->ref
== NULL
3364 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
3366 /* This doesn't catch all cases.
3367 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3368 and the surrounding thread. */
3369 sym
= arg
->symtree
->n
.sym
;
3370 decl
= gfc_get_symbol_decl (sym
);
3371 if (decl
== current_function_decl
&& sym
->attr
.function
3372 && (sym
->result
== sym
))
3373 decl
= gfc_get_fake_result_decl (sym
, 0);
3375 len
= sym
->ts
.u
.cl
->backend_decl
;
3380 /* Otherwise fall through. */
3383 /* Anybody stupid enough to do this deserves inefficient code. */
3384 ss
= gfc_walk_expr (arg
);
3385 gfc_init_se (&argse
, se
);
3386 if (ss
== gfc_ss_terminator
)
3387 gfc_conv_expr (&argse
, arg
);
3389 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3390 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3391 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3392 len
= argse
.string_length
;
3395 se
->expr
= convert (type
, len
);
3398 /* The length of a character string not including trailing blanks. */
3400 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
3402 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
3403 tree args
[2], type
, fndecl
;
3405 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3406 type
= gfc_typenode_for_spec (&expr
->ts
);
3409 fndecl
= gfor_fndecl_string_len_trim
;
3411 fndecl
= gfor_fndecl_string_len_trim_char4
;
3415 se
->expr
= build_call_expr_loc (input_location
,
3416 fndecl
, 2, args
[0], args
[1]);
3417 se
->expr
= convert (type
, se
->expr
);
3421 /* Returns the starting position of a substring within a string. */
3424 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
3427 tree logical4_type_node
= gfc_get_logical_type (4);
3431 unsigned int num_args
;
3433 args
= XALLOCAVEC (tree
, 5);
3435 /* Get number of arguments; characters count double due to the
3436 string length argument. Kind= is not passed to the library
3437 and thus ignored. */
3438 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
3443 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3444 type
= gfc_typenode_for_spec (&expr
->ts
);
3447 args
[4] = build_int_cst (logical4_type_node
, 0);
3449 args
[4] = convert (logical4_type_node
, args
[4]);
3451 fndecl
= build_addr (function
, current_function_decl
);
3452 se
->expr
= build_call_array_loc (input_location
,
3453 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3455 se
->expr
= convert (type
, se
->expr
);
3459 /* The ascii value for a single character. */
3461 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
3463 tree args
[2], type
, pchartype
;
3465 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3466 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
3467 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
3468 args
[1] = fold_build1 (NOP_EXPR
, pchartype
, args
[1]);
3469 type
= gfc_typenode_for_spec (&expr
->ts
);
3471 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3473 se
->expr
= convert (type
, se
->expr
);
3477 /* Intrinsic ISNAN calls __builtin_isnan. */
3480 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
3484 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3485 se
->expr
= build_call_expr_loc (input_location
,
3486 built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
3487 STRIP_TYPE_NOPS (se
->expr
);
3488 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3492 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3493 their argument against a constant integer value. */
3496 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
3500 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3501 se
->expr
= fold_build2 (EQ_EXPR
, gfc_typenode_for_spec (&expr
->ts
),
3502 arg
, build_int_cst (TREE_TYPE (arg
), value
));
3507 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3510 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
3518 unsigned int num_args
;
3520 num_args
= gfc_intrinsic_argument_list_length (expr
);
3521 args
= XALLOCAVEC (tree
, num_args
);
3523 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3524 if (expr
->ts
.type
!= BT_CHARACTER
)
3532 /* We do the same as in the non-character case, but the argument
3533 list is different because of the string length arguments. We
3534 also have to set the string length for the result. */
3541 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
3543 se
->string_length
= len
;
3545 type
= TREE_TYPE (tsource
);
3546 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
,
3547 fold_convert (type
, fsource
));
3551 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3553 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
3555 tree arg
, type
, tmp
, frexp
;
3557 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3559 type
= gfc_typenode_for_spec (&expr
->ts
);
3560 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3561 tmp
= gfc_create_var (integer_type_node
, NULL
);
3562 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
3563 fold_convert (type
, arg
),
3564 gfc_build_addr_expr (NULL_TREE
, tmp
));
3565 se
->expr
= fold_convert (type
, se
->expr
);
3569 /* NEAREST (s, dir) is translated into
3570 tmp = copysign (HUGE_VAL, dir);
3571 return nextafter (s, tmp);
3574 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
3576 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
3578 nextafter
= builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
3579 copysign
= builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3580 huge_val
= builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL
, expr
->ts
.kind
);
3582 type
= gfc_typenode_for_spec (&expr
->ts
);
3583 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3584 tmp
= build_call_expr_loc (input_location
, copysign
, 2,
3585 build_call_expr_loc (input_location
, huge_val
, 0),
3586 fold_convert (type
, args
[1]));
3587 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
3588 fold_convert (type
, args
[0]), tmp
);
3589 se
->expr
= fold_convert (type
, se
->expr
);
3593 /* SPACING (s) is translated into
3601 e = MAX_EXPR (e, emin);
3602 res = scalbn (1., e);
3606 where prec is the precision of s, gfc_real_kinds[k].digits,
3607 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3608 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3611 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
3613 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
3614 tree cond
, tmp
, frexp
, scalbn
;
3618 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3619 prec
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].digits
);
3620 emin
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].min_exponent
- 1);
3621 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
3623 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3624 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3626 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3627 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3629 type
= gfc_typenode_for_spec (&expr
->ts
);
3630 e
= gfc_create_var (integer_type_node
, NULL
);
3631 res
= gfc_create_var (type
, NULL
);
3634 /* Build the block for s /= 0. */
3635 gfc_start_block (&block
);
3636 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
3637 gfc_build_addr_expr (NULL_TREE
, e
));
3638 gfc_add_expr_to_block (&block
, tmp
);
3640 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, e
, prec
);
3641 gfc_add_modify (&block
, e
, fold_build2 (MAX_EXPR
, integer_type_node
,
3644 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
3645 build_real_from_int_cst (type
, integer_one_node
), e
);
3646 gfc_add_modify (&block
, res
, tmp
);
3648 /* Finish by building the IF statement. */
3649 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg
,
3650 build_real_from_int_cst (type
, integer_zero_node
));
3651 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
3652 gfc_finish_block (&block
));
3654 gfc_add_expr_to_block (&se
->pre
, tmp
);
3659 /* RRSPACING (s) is translated into
3666 x = scalbn (x, precision - e);
3670 where precision is gfc_real_kinds[k].digits. */
3673 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
3675 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
3679 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3680 prec
= gfc_real_kinds
[k
].digits
;
3682 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3683 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3684 fabs
= builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3686 type
= gfc_typenode_for_spec (&expr
->ts
);
3687 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3688 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3690 e
= gfc_create_var (integer_type_node
, NULL
);
3691 x
= gfc_create_var (type
, NULL
);
3692 gfc_add_modify (&se
->pre
, x
,
3693 build_call_expr_loc (input_location
, fabs
, 1, arg
));
3696 gfc_start_block (&block
);
3697 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
3698 gfc_build_addr_expr (NULL_TREE
, e
));
3699 gfc_add_expr_to_block (&block
, tmp
);
3701 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
,
3702 build_int_cst (NULL_TREE
, prec
), e
);
3703 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
3704 gfc_add_modify (&block
, x
, tmp
);
3705 stmt
= gfc_finish_block (&block
);
3707 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, x
,
3708 build_real_from_int_cst (type
, integer_zero_node
));
3709 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
3710 gfc_add_expr_to_block (&se
->pre
, tmp
);
3712 se
->expr
= fold_convert (type
, x
);
3716 /* SCALE (s, i) is translated into scalbn (s, i). */
3718 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
3720 tree args
[2], type
, scalbn
;
3722 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3724 type
= gfc_typenode_for_spec (&expr
->ts
);
3725 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3726 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
3727 fold_convert (type
, args
[0]),
3728 fold_convert (integer_type_node
, args
[1]));
3729 se
->expr
= fold_convert (type
, se
->expr
);
3733 /* SET_EXPONENT (s, i) is translated into
3734 scalbn (frexp (s, &dummy_int), i). */
3736 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
3738 tree args
[2], type
, tmp
, frexp
, scalbn
;
3740 frexp
= builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
3741 scalbn
= builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
3743 type
= gfc_typenode_for_spec (&expr
->ts
);
3744 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3746 tmp
= gfc_create_var (integer_type_node
, NULL
);
3747 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
3748 fold_convert (type
, args
[0]),
3749 gfc_build_addr_expr (NULL_TREE
, tmp
));
3750 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
3751 fold_convert (integer_type_node
, args
[1]));
3752 se
->expr
= fold_convert (type
, se
->expr
);
3757 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
3759 gfc_actual_arglist
*actual
;
3767 gfc_init_se (&argse
, NULL
);
3768 actual
= expr
->value
.function
.actual
;
3770 ss
= gfc_walk_expr (actual
->expr
);
3771 gcc_assert (ss
!= gfc_ss_terminator
);
3772 argse
.want_pointer
= 1;
3773 argse
.data_not_needed
= 1;
3774 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
3775 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3776 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3777 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
3779 /* Build the call to size0. */
3780 fncall0
= build_call_expr_loc (input_location
,
3781 gfor_fndecl_size0
, 1, arg1
);
3783 actual
= actual
->next
;
3787 gfc_init_se (&argse
, NULL
);
3788 gfc_conv_expr_type (&argse
, actual
->expr
,
3789 gfc_array_index_type
);
3790 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3792 /* Unusually, for an intrinsic, size does not exclude
3793 an optional arg2, so we must test for it. */
3794 if (actual
->expr
->expr_type
== EXPR_VARIABLE
3795 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
3796 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
3799 /* Build the call to size1. */
3800 fncall1
= build_call_expr_loc (input_location
,
3801 gfor_fndecl_size1
, 2,
3804 gfc_init_se (&argse
, NULL
);
3805 argse
.want_pointer
= 1;
3806 argse
.data_not_needed
= 1;
3807 gfc_conv_expr (&argse
, actual
->expr
);
3808 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3809 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3810 argse
.expr
, null_pointer_node
);
3811 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3812 se
->expr
= fold_build3 (COND_EXPR
, pvoid_type_node
,
3813 tmp
, fncall1
, fncall0
);
3817 se
->expr
= NULL_TREE
;
3818 argse
.expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3819 argse
.expr
, gfc_index_one_node
);
3822 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
3824 argse
.expr
= gfc_index_zero_node
;
3825 se
->expr
= NULL_TREE
;
3830 if (se
->expr
== NULL_TREE
)
3832 tree ubound
, lbound
;
3834 arg1
= build_fold_indirect_ref_loc (input_location
,
3836 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
3837 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
3838 se
->expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3840 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
->expr
,
3841 gfc_index_one_node
);
3842 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
3843 gfc_index_zero_node
);
3846 type
= gfc_typenode_for_spec (&expr
->ts
);
3847 se
->expr
= convert (type
, se
->expr
);
3851 /* Helper function to compute the size of a character variable,
3852 excluding the terminating null characters. The result has
3853 gfc_array_index_type type. */
3856 size_of_string_in_bytes (int kind
, tree string_length
)
3859 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
3861 bytesize
= build_int_cst (gfc_array_index_type
,
3862 gfc_character_kinds
[i
].bit_size
/ 8);
3864 return fold_build2 (MULT_EXPR
, gfc_array_index_type
, bytesize
,
3865 fold_convert (gfc_array_index_type
, string_length
));
3870 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
3882 arg
= expr
->value
.function
.actual
->expr
;
3884 gfc_init_se (&argse
, NULL
);
3885 ss
= gfc_walk_expr (arg
);
3887 if (ss
== gfc_ss_terminator
)
3889 if (arg
->ts
.type
== BT_CLASS
)
3890 gfc_add_component_ref (arg
, "$data");
3892 gfc_conv_expr_reference (&argse
, arg
);
3894 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
3897 /* Obtain the source word length. */
3898 if (arg
->ts
.type
== BT_CHARACTER
)
3899 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
3900 argse
.string_length
);
3902 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
3906 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
3907 argse
.want_pointer
= 0;
3908 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3909 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3911 /* Obtain the argument's word length. */
3912 if (arg
->ts
.type
== BT_CHARACTER
)
3913 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
3915 tmp
= fold_convert (gfc_array_index_type
,
3916 size_in_bytes (type
));
3917 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3919 /* Obtain the size of the array in bytes. */
3920 for (n
= 0; n
< arg
->rank
; n
++)
3923 idx
= gfc_rank_cst
[n
];
3924 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
3925 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
3926 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3928 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3929 tmp
, gfc_index_one_node
);
3930 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3932 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3934 se
->expr
= source_bytes
;
3937 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3942 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
3947 tree type
, result_type
, tmp
;
3949 arg
= expr
->value
.function
.actual
->expr
;
3950 gfc_init_se (&eight
, NULL
);
3951 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
3953 gfc_init_se (&argse
, NULL
);
3954 ss
= gfc_walk_expr (arg
);
3955 result_type
= gfc_get_int_type (expr
->ts
.kind
);
3957 if (ss
== gfc_ss_terminator
)
3959 if (arg
->ts
.type
== BT_CLASS
)
3961 gfc_add_component_ref (arg
, "$vptr");
3962 gfc_add_component_ref (arg
, "$size");
3963 gfc_conv_expr (&argse
, arg
);
3964 tmp
= fold_convert (result_type
, argse
.expr
);
3968 gfc_conv_expr_reference (&argse
, arg
);
3969 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
3974 argse
.want_pointer
= 0;
3975 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3976 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3979 /* Obtain the argument's word length. */
3980 if (arg
->ts
.type
== BT_CHARACTER
)
3981 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
3983 tmp
= fold_convert (result_type
, size_in_bytes (type
));
3986 se
->expr
= fold_build2 (MULT_EXPR
, result_type
, tmp
, eight
.expr
);
3987 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3991 /* Intrinsic string comparison functions. */
3994 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3998 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
4001 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
4002 expr
->value
.function
.actual
->expr
->ts
.kind
,
4004 se
->expr
= fold_build2 (op
, gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
4005 build_int_cst (TREE_TYPE (se
->expr
), 0));
4008 /* Generate a call to the adjustl/adjustr library function. */
4010 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
4018 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
4021 type
= TREE_TYPE (args
[2]);
4022 var
= gfc_conv_string_tmp (se
, type
, len
);
4025 tmp
= build_call_expr_loc (input_location
,
4026 fndecl
, 3, args
[0], args
[1], args
[2]);
4027 gfc_add_expr_to_block (&se
->pre
, tmp
);
4029 se
->string_length
= len
;
4033 /* Generate code for the TRANSFER intrinsic:
4035 DEST = TRANSFER (SOURCE, MOLD)
4037 typeof<DEST> = typeof<MOLD>
4042 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4044 typeof<DEST> = typeof<MOLD>
4046 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4047 sizeof (DEST(0) * SIZE). */
4049 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
4065 gfc_actual_arglist
*arg
;
4075 info
= &se
->ss
->data
.info
;
4077 /* Convert SOURCE. The output from this stage is:-
4078 source_bytes = length of the source in bytes
4079 source = pointer to the source data. */
4080 arg
= expr
->value
.function
.actual
;
4082 /* Ensure double transfer through LOGICAL preserves all
4084 if (arg
->expr
->expr_type
== EXPR_FUNCTION
4085 && arg
->expr
->value
.function
.esym
== NULL
4086 && arg
->expr
->value
.function
.isym
!= NULL
4087 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
4088 && arg
->expr
->ts
.type
== BT_LOGICAL
4089 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
4090 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
4092 gfc_init_se (&argse
, NULL
);
4093 ss
= gfc_walk_expr (arg
->expr
);
4095 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
4097 /* Obtain the pointer to source and the length of source in bytes. */
4098 if (ss
== gfc_ss_terminator
)
4100 gfc_conv_expr_reference (&argse
, arg
->expr
);
4101 source
= argse
.expr
;
4103 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4106 /* Obtain the source word length. */
4107 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4108 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
4109 argse
.string_length
);
4111 tmp
= fold_convert (gfc_array_index_type
,
4112 size_in_bytes (source_type
));
4116 argse
.want_pointer
= 0;
4117 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
4118 source
= gfc_conv_descriptor_data_get (argse
.expr
);
4119 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4121 /* Repack the source if not a full variable array. */
4122 if (arg
->expr
->expr_type
== EXPR_VARIABLE
4123 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
4125 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
4127 if (gfc_option
.warn_array_temp
)
4128 gfc_warning ("Creating array temporary at %L", &expr
->where
);
4130 source
= build_call_expr_loc (input_location
,
4131 gfor_fndecl_in_pack
, 1, tmp
);
4132 source
= gfc_evaluate_now (source
, &argse
.pre
);
4134 /* Free the temporary. */
4135 gfc_start_block (&block
);
4136 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
4137 gfc_add_expr_to_block (&block
, tmp
);
4138 stmt
= gfc_finish_block (&block
);
4140 /* Clean up if it was repacked. */
4141 gfc_init_block (&block
);
4142 tmp
= gfc_conv_array_data (argse
.expr
);
4143 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
4144 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
4145 build_empty_stmt (input_location
));
4146 gfc_add_expr_to_block (&block
, tmp
);
4147 gfc_add_block_to_block (&block
, &se
->post
);
4148 gfc_init_block (&se
->post
);
4149 gfc_add_block_to_block (&se
->post
, &block
);
4152 /* Obtain the source word length. */
4153 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4154 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
4155 argse
.string_length
);
4157 tmp
= fold_convert (gfc_array_index_type
,
4158 size_in_bytes (source_type
));
4160 /* Obtain the size of the array in bytes. */
4161 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
4162 for (n
= 0; n
< arg
->expr
->rank
; n
++)
4165 idx
= gfc_rank_cst
[n
];
4166 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4167 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
4168 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
4169 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4171 gfc_add_modify (&argse
.pre
, extent
, tmp
);
4172 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4173 extent
, gfc_index_one_node
);
4174 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4179 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4180 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4181 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4183 /* Now convert MOLD. The outputs are:
4184 mold_type = the TREE type of MOLD
4185 dest_word_len = destination word length in bytes. */
4188 gfc_init_se (&argse
, NULL
);
4189 ss
= gfc_walk_expr (arg
->expr
);
4191 scalar_mold
= arg
->expr
->rank
== 0;
4193 if (ss
== gfc_ss_terminator
)
4195 gfc_conv_expr_reference (&argse
, arg
->expr
);
4196 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4201 gfc_init_se (&argse
, NULL
);
4202 argse
.want_pointer
= 0;
4203 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
4204 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4207 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4208 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4210 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
4212 /* If this TRANSFER is nested in another TRANSFER, use a type
4213 that preserves all bits. */
4214 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
4215 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
4218 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4220 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
4221 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
4224 tmp
= fold_convert (gfc_array_index_type
,
4225 size_in_bytes (mold_type
));
4227 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
4228 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
4230 /* Finally convert SIZE, if it is present. */
4232 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
4236 gfc_init_se (&argse
, NULL
);
4237 gfc_conv_expr_reference (&argse
, arg
->expr
);
4238 tmp
= convert (gfc_array_index_type
,
4239 build_fold_indirect_ref_loc (input_location
,
4241 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4242 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4247 /* Separate array and scalar results. */
4248 if (scalar_mold
&& tmp
== NULL_TREE
)
4249 goto scalar_transfer
;
4251 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
4252 if (tmp
!= NULL_TREE
)
4253 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4254 tmp
, dest_word_len
);
4258 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
4259 gfc_add_modify (&se
->pre
, size_words
,
4260 fold_build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
4261 size_bytes
, dest_word_len
));
4263 /* Evaluate the bounds of the result. If the loop range exists, we have
4264 to check if it is too large. If so, we modify loop->to be consistent
4265 with min(size, size(source)). Otherwise, size is made consistent with
4266 the loop range, so that the right number of bytes is transferred.*/
4267 n
= se
->loop
->order
[0];
4268 if (se
->loop
->to
[n
] != NULL_TREE
)
4270 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4271 se
->loop
->to
[n
], se
->loop
->from
[n
]);
4272 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4273 tmp
, gfc_index_one_node
);
4274 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
4276 gfc_add_modify (&se
->pre
, size_words
, tmp
);
4277 gfc_add_modify (&se
->pre
, size_bytes
,
4278 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4279 size_words
, dest_word_len
));
4280 upper
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4281 size_words
, se
->loop
->from
[n
]);
4282 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4283 upper
, gfc_index_one_node
);
4287 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4288 size_words
, gfc_index_one_node
);
4289 se
->loop
->from
[n
] = gfc_index_zero_node
;
4292 se
->loop
->to
[n
] = upper
;
4294 /* Build a destination descriptor, using the pointer, source, as the
4296 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
4297 info
, mold_type
, NULL_TREE
, false, true, false,
4300 /* Cast the pointer to the result. */
4301 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
4302 tmp
= fold_convert (pvoid_type_node
, tmp
);
4304 /* Use memcpy to do the transfer. */
4305 tmp
= build_call_expr_loc (input_location
,
4306 built_in_decls
[BUILT_IN_MEMCPY
],
4309 fold_convert (pvoid_type_node
, source
),
4310 fold_build2 (MIN_EXPR
, gfc_array_index_type
,
4311 size_bytes
, source_bytes
));
4312 gfc_add_expr_to_block (&se
->pre
, tmp
);
4314 se
->expr
= info
->descriptor
;
4315 if (expr
->ts
.type
== BT_CHARACTER
)
4316 se
->string_length
= dest_word_len
;
4320 /* Deal with scalar results. */
4322 extent
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
4323 dest_word_len
, source_bytes
);
4324 extent
= fold_build2 (MAX_EXPR
, gfc_array_index_type
,
4325 extent
, gfc_index_zero_node
);
4327 if (expr
->ts
.type
== BT_CHARACTER
)
4332 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
4333 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
4336 /* If source is longer than the destination, use a pointer to
4337 the source directly. */
4338 gfc_init_block (&block
);
4339 gfc_add_modify (&block
, tmpdecl
, ptr
);
4340 direct
= gfc_finish_block (&block
);
4342 /* Otherwise, allocate a string with the length of the destination
4343 and copy the source into it. */
4344 gfc_init_block (&block
);
4345 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
4346 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
4347 gfc_add_modify (&block
, tmpdecl
,
4348 fold_convert (TREE_TYPE (ptr
), tmp
));
4349 tmp
= build_call_expr_loc (input_location
,
4350 built_in_decls
[BUILT_IN_MEMCPY
], 3,
4351 fold_convert (pvoid_type_node
, tmpdecl
),
4352 fold_convert (pvoid_type_node
, ptr
),
4354 gfc_add_expr_to_block (&block
, tmp
);
4355 indirect
= gfc_finish_block (&block
);
4357 /* Wrap it up with the condition. */
4358 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
,
4359 dest_word_len
, source_bytes
);
4360 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
4361 gfc_add_expr_to_block (&se
->pre
, tmp
);
4364 se
->string_length
= dest_word_len
;
4368 tmpdecl
= gfc_create_var (mold_type
, "transfer");
4370 ptr
= convert (build_pointer_type (mold_type
), source
);
4372 /* Use memcpy to do the transfer. */
4373 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
4374 tmp
= build_call_expr_loc (input_location
,
4375 built_in_decls
[BUILT_IN_MEMCPY
], 3,
4376 fold_convert (pvoid_type_node
, tmp
),
4377 fold_convert (pvoid_type_node
, ptr
),
4379 gfc_add_expr_to_block (&se
->pre
, tmp
);
4386 /* Generate code for the ALLOCATED intrinsic.
4387 Generate inline code that directly check the address of the argument. */
4390 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
4392 gfc_actual_arglist
*arg1
;
4397 gfc_init_se (&arg1se
, NULL
);
4398 arg1
= expr
->value
.function
.actual
;
4399 ss1
= gfc_walk_expr (arg1
->expr
);
4401 if (ss1
== gfc_ss_terminator
)
4403 /* Allocatable scalar. */
4404 arg1se
.want_pointer
= 1;
4405 if (arg1
->expr
->ts
.type
== BT_CLASS
)
4406 gfc_add_component_ref (arg1
->expr
, "$data");
4407 gfc_conv_expr (&arg1se
, arg1
->expr
);
4412 /* Allocatable array. */
4413 arg1se
.descriptor_only
= 1;
4414 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4415 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
4418 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
4419 tmp
, fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
4420 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
4424 /* Generate code for the ASSOCIATED intrinsic.
4425 If both POINTER and TARGET are arrays, generate a call to library function
4426 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4427 In other cases, generate inline code that directly compare the address of
4428 POINTER with the address of TARGET. */
4431 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
4433 gfc_actual_arglist
*arg1
;
4434 gfc_actual_arglist
*arg2
;
4439 tree nonzero_charlen
;
4440 tree nonzero_arraylen
;
4443 gfc_init_se (&arg1se
, NULL
);
4444 gfc_init_se (&arg2se
, NULL
);
4445 arg1
= expr
->value
.function
.actual
;
4446 if (arg1
->expr
->ts
.type
== BT_CLASS
)
4447 gfc_add_component_ref (arg1
->expr
, "$data");
4449 ss1
= gfc_walk_expr (arg1
->expr
);
4453 /* No optional target. */
4454 if (ss1
== gfc_ss_terminator
)
4456 /* A pointer to a scalar. */
4457 arg1se
.want_pointer
= 1;
4458 gfc_conv_expr (&arg1se
, arg1
->expr
);
4463 /* A pointer to an array. */
4464 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4465 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
4467 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
4468 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
4469 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp2
,
4470 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
4475 /* An optional target. */
4476 if (arg2
->expr
->ts
.type
== BT_CLASS
)
4477 gfc_add_component_ref (arg2
->expr
, "$data");
4478 ss2
= gfc_walk_expr (arg2
->expr
);
4480 nonzero_charlen
= NULL_TREE
;
4481 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
4482 nonzero_charlen
= fold_build2 (NE_EXPR
, boolean_type_node
,
4483 arg1
->expr
->ts
.u
.cl
->backend_decl
,
4486 if (ss1
== gfc_ss_terminator
)
4488 /* A pointer to a scalar. */
4489 gcc_assert (ss2
== gfc_ss_terminator
);
4490 arg1se
.want_pointer
= 1;
4491 gfc_conv_expr (&arg1se
, arg1
->expr
);
4492 arg2se
.want_pointer
= 1;
4493 gfc_conv_expr (&arg2se
, arg2
->expr
);
4494 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
4495 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
4496 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4497 arg1se
.expr
, arg2se
.expr
);
4498 tmp2
= fold_build2 (NE_EXPR
, boolean_type_node
,
4499 arg1se
.expr
, null_pointer_node
);
4500 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4505 /* An array pointer of zero length is not associated if target is
4507 arg1se
.descriptor_only
= 1;
4508 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
4509 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
,
4510 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
4511 nonzero_arraylen
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
4512 build_int_cst (TREE_TYPE (tmp
), 0));
4514 /* A pointer to an array, call library function _gfor_associated. */
4515 gcc_assert (ss2
!= gfc_ss_terminator
);
4516 arg1se
.want_pointer
= 1;
4517 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4519 arg2se
.want_pointer
= 1;
4520 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
4521 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
4522 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
4523 se
->expr
= build_call_expr_loc (input_location
,
4524 gfor_fndecl_associated
, 2,
4525 arg1se
.expr
, arg2se
.expr
);
4526 se
->expr
= convert (boolean_type_node
, se
->expr
);
4527 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4528 se
->expr
, nonzero_arraylen
);
4531 /* If target is present zero character length pointers cannot
4533 if (nonzero_charlen
!= NULL_TREE
)
4534 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4535 se
->expr
, nonzero_charlen
);
4538 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4542 /* Generate code for the SAME_TYPE_AS intrinsic.
4543 Generate inline code that directly checks the vindices. */
4546 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
4552 gfc_init_se (&se1
, NULL
);
4553 gfc_init_se (&se2
, NULL
);
4555 a
= expr
->value
.function
.actual
->expr
;
4556 b
= expr
->value
.function
.actual
->next
->expr
;
4558 if (a
->ts
.type
== BT_CLASS
)
4560 gfc_add_component_ref (a
, "$vptr");
4561 gfc_add_component_ref (a
, "$hash");
4563 else if (a
->ts
.type
== BT_DERIVED
)
4564 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4565 a
->ts
.u
.derived
->hash_value
);
4567 if (b
->ts
.type
== BT_CLASS
)
4569 gfc_add_component_ref (b
, "$vptr");
4570 gfc_add_component_ref (b
, "$hash");
4572 else if (b
->ts
.type
== BT_DERIVED
)
4573 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4574 b
->ts
.u
.derived
->hash_value
);
4576 gfc_conv_expr (&se1
, a
);
4577 gfc_conv_expr (&se2
, b
);
4579 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4580 se1
.expr
, fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
4581 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
4585 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4588 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
4592 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4593 se
->expr
= build_call_expr_loc (input_location
,
4594 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
4595 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4599 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4602 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
4606 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4608 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4609 type
= gfc_get_int_type (4);
4610 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
4612 /* Convert it to the required type. */
4613 type
= gfc_typenode_for_spec (&expr
->ts
);
4614 se
->expr
= build_call_expr_loc (input_location
,
4615 gfor_fndecl_si_kind
, 1, arg
);
4616 se
->expr
= fold_convert (type
, se
->expr
);
4620 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4623 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
4625 gfc_actual_arglist
*actual
;
4628 VEC(tree
,gc
) *args
= NULL
;
4630 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4632 gfc_init_se (&argse
, se
);
4634 /* Pass a NULL pointer for an absent arg. */
4635 if (actual
->expr
== NULL
)
4636 argse
.expr
= null_pointer_node
;
4642 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4644 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4645 ts
.type
= BT_INTEGER
;
4646 ts
.kind
= gfc_c_int_kind
;
4647 gfc_convert_type (actual
->expr
, &ts
, 2);
4649 gfc_conv_expr_reference (&argse
, actual
->expr
);
4652 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4653 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4654 VEC_safe_push (tree
, gc
, args
, argse
.expr
);
4657 /* Convert it to the required type. */
4658 type
= gfc_typenode_for_spec (&expr
->ts
);
4659 se
->expr
= build_call_expr_loc_vec (input_location
,
4660 gfor_fndecl_sr_kind
, args
);
4661 se
->expr
= fold_convert (type
, se
->expr
);
4665 /* Generate code for TRIM (A) intrinsic function. */
4668 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
4678 unsigned int num_args
;
4680 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4681 args
= XALLOCAVEC (tree
, num_args
);
4683 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4684 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
4685 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4687 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4688 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4691 if (expr
->ts
.kind
== 1)
4692 function
= gfor_fndecl_string_trim
;
4693 else if (expr
->ts
.kind
== 4)
4694 function
= gfor_fndecl_string_trim_char4
;
4698 fndecl
= build_addr (function
, current_function_decl
);
4699 tmp
= build_call_array_loc (input_location
,
4700 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4702 gfc_add_expr_to_block (&se
->pre
, tmp
);
4704 /* Free the temporary afterwards, if necessary. */
4705 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4706 len
, build_int_cst (TREE_TYPE (len
), 0));
4707 tmp
= gfc_call_free (var
);
4708 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4709 gfc_add_expr_to_block (&se
->post
, tmp
);
4712 se
->string_length
= len
;
4716 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
4719 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
4721 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
4722 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
4724 stmtblock_t block
, body
;
4727 /* We store in charsize the size of a character. */
4728 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
4729 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
4731 /* Get the arguments. */
4732 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4733 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
4735 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
4736 ncopies_type
= TREE_TYPE (ncopies
);
4738 /* Check that NCOPIES is not negative. */
4739 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
4740 build_int_cst (ncopies_type
, 0));
4741 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4742 "Argument NCOPIES of REPEAT intrinsic is negative "
4743 "(its value is %lld)",
4744 fold_convert (long_integer_type_node
, ncopies
));
4746 /* If the source length is zero, any non negative value of NCOPIES
4747 is valid, and nothing happens. */
4748 n
= gfc_create_var (ncopies_type
, "ncopies");
4749 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4750 build_int_cst (size_type_node
, 0));
4751 tmp
= fold_build3 (COND_EXPR
, ncopies_type
, cond
,
4752 build_int_cst (ncopies_type
, 0), ncopies
);
4753 gfc_add_modify (&se
->pre
, n
, tmp
);
4756 /* Check that ncopies is not too large: ncopies should be less than
4757 (or equal to) MAX / slen, where MAX is the maximal integer of
4758 the gfc_charlen_type_node type. If slen == 0, we need a special
4759 case to avoid the division by zero. */
4760 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4761 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
4762 max
= fold_build2 (TRUNC_DIV_EXPR
, size_type_node
,
4763 fold_convert (size_type_node
, max
), slen
);
4764 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
4765 ? size_type_node
: ncopies_type
;
4766 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4767 fold_convert (largest
, ncopies
),
4768 fold_convert (largest
, max
));
4769 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4770 build_int_cst (size_type_node
, 0));
4771 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
, boolean_false_node
,
4773 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4774 "Argument NCOPIES of REPEAT intrinsic is too large");
4776 /* Compute the destination length. */
4777 dlen
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4778 fold_convert (gfc_charlen_type_node
, slen
),
4779 fold_convert (gfc_charlen_type_node
, ncopies
));
4780 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
4781 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
4783 /* Generate the code to do the repeat operation:
4784 for (i = 0; i < ncopies; i++)
4785 memmove (dest + (i * slen * size), src, slen*size); */
4786 gfc_start_block (&block
);
4787 count
= gfc_create_var (ncopies_type
, "count");
4788 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
4789 exit_label
= gfc_build_label_decl (NULL_TREE
);
4791 /* Start the loop body. */
4792 gfc_start_block (&body
);
4794 /* Exit the loop if count >= ncopies. */
4795 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, count
, ncopies
);
4796 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4797 TREE_USED (exit_label
) = 1;
4798 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
4799 build_empty_stmt (input_location
));
4800 gfc_add_expr_to_block (&body
, tmp
);
4802 /* Call memmove (dest + (i*slen*size), src, slen*size). */
4803 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4804 fold_convert (gfc_charlen_type_node
, slen
),
4805 fold_convert (gfc_charlen_type_node
, count
));
4806 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4807 tmp
, fold_convert (gfc_charlen_type_node
, size
));
4808 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pvoid_type_node
,
4809 fold_convert (pvoid_type_node
, dest
),
4810 fold_convert (sizetype
, tmp
));
4811 tmp
= build_call_expr_loc (input_location
,
4812 built_in_decls
[BUILT_IN_MEMMOVE
], 3, tmp
, src
,
4813 fold_build2 (MULT_EXPR
, size_type_node
, slen
,
4814 fold_convert (size_type_node
, size
)));
4815 gfc_add_expr_to_block (&body
, tmp
);
4817 /* Increment count. */
4818 tmp
= fold_build2 (PLUS_EXPR
, ncopies_type
,
4819 count
, build_int_cst (TREE_TYPE (count
), 1));
4820 gfc_add_modify (&body
, count
, tmp
);
4822 /* Build the loop. */
4823 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
4824 gfc_add_expr_to_block (&block
, tmp
);
4826 /* Add the exit label. */
4827 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4828 gfc_add_expr_to_block (&block
, tmp
);
4830 /* Finish the block. */
4831 tmp
= gfc_finish_block (&block
);
4832 gfc_add_expr_to_block (&se
->pre
, tmp
);
4834 /* Set the result value. */
4836 se
->string_length
= dlen
;
4840 /* Generate code for the IARGC intrinsic. */
4843 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
4849 /* Call the library function. This always returns an INTEGER(4). */
4850 fndecl
= gfor_fndecl_iargc
;
4851 tmp
= build_call_expr_loc (input_location
,
4854 /* Convert it to the required type. */
4855 type
= gfc_typenode_for_spec (&expr
->ts
);
4856 tmp
= fold_convert (type
, tmp
);
4862 /* The loc intrinsic returns the address of its argument as
4863 gfc_index_integer_kind integer. */
4866 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
4872 gcc_assert (!se
->ss
);
4874 arg_expr
= expr
->value
.function
.actual
->expr
;
4875 ss
= gfc_walk_expr (arg_expr
);
4876 if (ss
== gfc_ss_terminator
)
4877 gfc_conv_expr_reference (se
, arg_expr
);
4879 gfc_conv_array_parameter (se
, arg_expr
, ss
, true, NULL
, NULL
, NULL
);
4880 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
4882 /* Create a temporary variable for loc return value. Without this,
4883 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4884 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
4885 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
4886 se
->expr
= temp_var
;
4889 /* Generate code for an intrinsic function. Some map directly to library
4890 calls, others get special handling. In some cases the name of the function
4891 used depends on the type specifiers. */
4894 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
4900 name
= &expr
->value
.function
.name
[2];
4902 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
4904 lib
= gfc_is_intrinsic_libcall (expr
);
4908 se
->ignore_optional
= 1;
4910 switch (expr
->value
.function
.isym
->id
)
4912 case GFC_ISYM_EOSHIFT
:
4914 case GFC_ISYM_RESHAPE
:
4915 /* For all of those the first argument specifies the type and the
4916 third is optional. */
4917 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
4921 gfc_conv_intrinsic_funcall (se
, expr
);
4929 switch (expr
->value
.function
.isym
->id
)
4934 case GFC_ISYM_REPEAT
:
4935 gfc_conv_intrinsic_repeat (se
, expr
);
4939 gfc_conv_intrinsic_trim (se
, expr
);
4942 case GFC_ISYM_SC_KIND
:
4943 gfc_conv_intrinsic_sc_kind (se
, expr
);
4946 case GFC_ISYM_SI_KIND
:
4947 gfc_conv_intrinsic_si_kind (se
, expr
);
4950 case GFC_ISYM_SR_KIND
:
4951 gfc_conv_intrinsic_sr_kind (se
, expr
);
4954 case GFC_ISYM_EXPONENT
:
4955 gfc_conv_intrinsic_exponent (se
, expr
);
4959 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4961 fndecl
= gfor_fndecl_string_scan
;
4963 fndecl
= gfor_fndecl_string_scan_char4
;
4967 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4970 case GFC_ISYM_VERIFY
:
4971 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4973 fndecl
= gfor_fndecl_string_verify
;
4975 fndecl
= gfor_fndecl_string_verify_char4
;
4979 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4982 case GFC_ISYM_ALLOCATED
:
4983 gfc_conv_allocated (se
, expr
);
4986 case GFC_ISYM_ASSOCIATED
:
4987 gfc_conv_associated(se
, expr
);
4990 case GFC_ISYM_SAME_TYPE_AS
:
4991 gfc_conv_same_type_as (se
, expr
);
4995 gfc_conv_intrinsic_abs (se
, expr
);
4998 case GFC_ISYM_ADJUSTL
:
4999 if (expr
->ts
.kind
== 1)
5000 fndecl
= gfor_fndecl_adjustl
;
5001 else if (expr
->ts
.kind
== 4)
5002 fndecl
= gfor_fndecl_adjustl_char4
;
5006 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5009 case GFC_ISYM_ADJUSTR
:
5010 if (expr
->ts
.kind
== 1)
5011 fndecl
= gfor_fndecl_adjustr
;
5012 else if (expr
->ts
.kind
== 4)
5013 fndecl
= gfor_fndecl_adjustr_char4
;
5017 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5020 case GFC_ISYM_AIMAG
:
5021 gfc_conv_intrinsic_imagpart (se
, expr
);
5025 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
5029 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
5032 case GFC_ISYM_ANINT
:
5033 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
5037 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
5041 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
5044 case GFC_ISYM_BTEST
:
5045 gfc_conv_intrinsic_btest (se
, expr
);
5048 case GFC_ISYM_ACHAR
:
5050 gfc_conv_intrinsic_char (se
, expr
);
5053 case GFC_ISYM_CONVERSION
:
5055 case GFC_ISYM_LOGICAL
:
5057 gfc_conv_intrinsic_conversion (se
, expr
);
5060 /* Integer conversions are handled separately to make sure we get the
5061 correct rounding mode. */
5066 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
5070 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
5073 case GFC_ISYM_CEILING
:
5074 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
5077 case GFC_ISYM_FLOOR
:
5078 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
5082 gfc_conv_intrinsic_mod (se
, expr
, 0);
5085 case GFC_ISYM_MODULO
:
5086 gfc_conv_intrinsic_mod (se
, expr
, 1);
5089 case GFC_ISYM_CMPLX
:
5090 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
5093 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
5094 gfc_conv_intrinsic_iargc (se
, expr
);
5097 case GFC_ISYM_COMPLEX
:
5098 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
5101 case GFC_ISYM_CONJG
:
5102 gfc_conv_intrinsic_conjg (se
, expr
);
5105 case GFC_ISYM_COUNT
:
5106 gfc_conv_intrinsic_count (se
, expr
);
5109 case GFC_ISYM_CTIME
:
5110 gfc_conv_intrinsic_ctime (se
, expr
);
5114 gfc_conv_intrinsic_dim (se
, expr
);
5117 case GFC_ISYM_DOT_PRODUCT
:
5118 gfc_conv_intrinsic_dot_product (se
, expr
);
5121 case GFC_ISYM_DPROD
:
5122 gfc_conv_intrinsic_dprod (se
, expr
);
5125 case GFC_ISYM_FDATE
:
5126 gfc_conv_intrinsic_fdate (se
, expr
);
5129 case GFC_ISYM_FRACTION
:
5130 gfc_conv_intrinsic_fraction (se
, expr
);
5134 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
5137 case GFC_ISYM_IBCLR
:
5138 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
5141 case GFC_ISYM_IBITS
:
5142 gfc_conv_intrinsic_ibits (se
, expr
);
5145 case GFC_ISYM_IBSET
:
5146 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
5149 case GFC_ISYM_IACHAR
:
5150 case GFC_ISYM_ICHAR
:
5151 /* We assume ASCII character sequence. */
5152 gfc_conv_intrinsic_ichar (se
, expr
);
5155 case GFC_ISYM_IARGC
:
5156 gfc_conv_intrinsic_iargc (se
, expr
);
5160 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
5163 case GFC_ISYM_INDEX
:
5164 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5166 fndecl
= gfor_fndecl_string_index
;
5168 fndecl
= gfor_fndecl_string_index_char4
;
5172 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
5176 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
5179 case GFC_ISYM_IS_IOSTAT_END
:
5180 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
5183 case GFC_ISYM_IS_IOSTAT_EOR
:
5184 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
5187 case GFC_ISYM_ISNAN
:
5188 gfc_conv_intrinsic_isnan (se
, expr
);
5191 case GFC_ISYM_LSHIFT
:
5192 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
5195 case GFC_ISYM_RSHIFT
:
5196 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
5199 case GFC_ISYM_ISHFT
:
5200 gfc_conv_intrinsic_ishft (se
, expr
);
5203 case GFC_ISYM_ISHFTC
:
5204 gfc_conv_intrinsic_ishftc (se
, expr
);
5207 case GFC_ISYM_LEADZ
:
5208 gfc_conv_intrinsic_leadz (se
, expr
);
5211 case GFC_ISYM_TRAILZ
:
5212 gfc_conv_intrinsic_trailz (se
, expr
);
5215 case GFC_ISYM_LBOUND
:
5216 gfc_conv_intrinsic_bound (se
, expr
, 0);
5219 case GFC_ISYM_TRANSPOSE
:
5220 if (se
->ss
&& se
->ss
->useflags
)
5222 gfc_conv_tmp_array_ref (se
);
5223 gfc_advance_se_ss_chain (se
);
5226 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
5230 gfc_conv_intrinsic_len (se
, expr
);
5233 case GFC_ISYM_LEN_TRIM
:
5234 gfc_conv_intrinsic_len_trim (se
, expr
);
5238 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
5242 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
5246 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
5250 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
5254 if (expr
->ts
.type
== BT_CHARACTER
)
5255 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
5257 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
5260 case GFC_ISYM_MAXLOC
:
5261 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
5264 case GFC_ISYM_MAXVAL
:
5265 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
5268 case GFC_ISYM_MERGE
:
5269 gfc_conv_intrinsic_merge (se
, expr
);
5273 if (expr
->ts
.type
== BT_CHARACTER
)
5274 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
5276 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
5279 case GFC_ISYM_MINLOC
:
5280 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
5283 case GFC_ISYM_MINVAL
:
5284 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
5287 case GFC_ISYM_NEAREST
:
5288 gfc_conv_intrinsic_nearest (se
, expr
);
5292 gfc_conv_intrinsic_not (se
, expr
);
5296 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
5299 case GFC_ISYM_PRESENT
:
5300 gfc_conv_intrinsic_present (se
, expr
);
5303 case GFC_ISYM_PRODUCT
:
5304 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
5307 case GFC_ISYM_RRSPACING
:
5308 gfc_conv_intrinsic_rrspacing (se
, expr
);
5311 case GFC_ISYM_SET_EXPONENT
:
5312 gfc_conv_intrinsic_set_exponent (se
, expr
);
5315 case GFC_ISYM_SCALE
:
5316 gfc_conv_intrinsic_scale (se
, expr
);
5320 gfc_conv_intrinsic_sign (se
, expr
);
5324 gfc_conv_intrinsic_size (se
, expr
);
5327 case GFC_ISYM_SIZEOF
:
5328 case GFC_ISYM_C_SIZEOF
:
5329 gfc_conv_intrinsic_sizeof (se
, expr
);
5332 case GFC_ISYM_STORAGE_SIZE
:
5333 gfc_conv_intrinsic_storage_size (se
, expr
);
5336 case GFC_ISYM_SPACING
:
5337 gfc_conv_intrinsic_spacing (se
, expr
);
5341 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
5344 case GFC_ISYM_TRANSFER
:
5345 if (se
->ss
&& se
->ss
->useflags
)
5347 /* Access the previously obtained result. */
5348 gfc_conv_tmp_array_ref (se
);
5349 gfc_advance_se_ss_chain (se
);
5352 gfc_conv_intrinsic_transfer (se
, expr
);
5355 case GFC_ISYM_TTYNAM
:
5356 gfc_conv_intrinsic_ttynam (se
, expr
);
5359 case GFC_ISYM_UBOUND
:
5360 gfc_conv_intrinsic_bound (se
, expr
, 1);
5364 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
5368 gfc_conv_intrinsic_loc (se
, expr
);
5371 case GFC_ISYM_ACCESS
:
5372 case GFC_ISYM_CHDIR
:
5373 case GFC_ISYM_CHMOD
:
5374 case GFC_ISYM_DTIME
:
5375 case GFC_ISYM_ETIME
:
5376 case GFC_ISYM_EXTENDS_TYPE_OF
:
5378 case GFC_ISYM_FGETC
:
5381 case GFC_ISYM_FPUTC
:
5382 case GFC_ISYM_FSTAT
:
5383 case GFC_ISYM_FTELL
:
5384 case GFC_ISYM_GETCWD
:
5385 case GFC_ISYM_GETGID
:
5386 case GFC_ISYM_GETPID
:
5387 case GFC_ISYM_GETUID
:
5388 case GFC_ISYM_HOSTNM
:
5390 case GFC_ISYM_IERRNO
:
5391 case GFC_ISYM_IRAND
:
5392 case GFC_ISYM_ISATTY
:
5395 case GFC_ISYM_LSTAT
:
5396 case GFC_ISYM_MALLOC
:
5397 case GFC_ISYM_MATMUL
:
5398 case GFC_ISYM_MCLOCK
:
5399 case GFC_ISYM_MCLOCK8
:
5401 case GFC_ISYM_RENAME
:
5402 case GFC_ISYM_SECOND
:
5403 case GFC_ISYM_SECNDS
:
5404 case GFC_ISYM_SIGNAL
:
5406 case GFC_ISYM_SYMLNK
:
5407 case GFC_ISYM_SYSTEM
:
5409 case GFC_ISYM_TIME8
:
5410 case GFC_ISYM_UMASK
:
5411 case GFC_ISYM_UNLINK
:
5413 gfc_conv_intrinsic_funcall (se
, expr
);
5416 case GFC_ISYM_EOSHIFT
:
5418 case GFC_ISYM_RESHAPE
:
5419 /* For those, expr->rank should always be >0 and thus the if above the
5420 switch should have matched. */
5425 gfc_conv_intrinsic_lib_function (se
, expr
);
5431 /* This generates code to execute before entering the scalarization loop.
5432 Currently does nothing. */
5435 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
5437 switch (ss
->expr
->value
.function
.isym
->id
)
5439 case GFC_ISYM_UBOUND
:
5440 case GFC_ISYM_LBOUND
:
5449 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5450 inside the scalarization loop. */
5453 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
5457 /* The two argument version returns a scalar. */
5458 if (expr
->value
.function
.actual
->next
->expr
)
5461 newss
= gfc_get_ss ();
5462 newss
->type
= GFC_SS_INTRINSIC
;
5465 newss
->data
.info
.dimen
= 1;
5471 /* Walk an intrinsic array libcall. */
5474 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
5478 gcc_assert (expr
->rank
> 0);
5480 newss
= gfc_get_ss ();
5481 newss
->type
= GFC_SS_FUNCTION
;
5484 newss
->data
.info
.dimen
= expr
->rank
;
5490 /* Returns nonzero if the specified intrinsic function call maps directly to
5491 an external library call. Should only be used for functions that return
5495 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
5497 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
5498 gcc_assert (expr
->rank
> 0);
5500 switch (expr
->value
.function
.isym
->id
)
5504 case GFC_ISYM_COUNT
:
5506 case GFC_ISYM_MATMUL
:
5507 case GFC_ISYM_MAXLOC
:
5508 case GFC_ISYM_MAXVAL
:
5509 case GFC_ISYM_MINLOC
:
5510 case GFC_ISYM_MINVAL
:
5511 case GFC_ISYM_PRODUCT
:
5513 case GFC_ISYM_SHAPE
:
5514 case GFC_ISYM_SPREAD
:
5515 case GFC_ISYM_TRANSPOSE
:
5517 /* Ignore absent optional parameters. */
5520 case GFC_ISYM_RESHAPE
:
5521 case GFC_ISYM_CSHIFT
:
5522 case GFC_ISYM_EOSHIFT
:
5524 case GFC_ISYM_UNPACK
:
5525 /* Pass absent optional parameters. */
5533 /* Walk an intrinsic function. */
5535 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
5536 gfc_intrinsic_sym
* isym
)
5540 if (isym
->elemental
)
5541 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
5543 if (expr
->rank
== 0)
5546 if (gfc_is_intrinsic_libcall (expr
))
5547 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5549 /* Special cases. */
5552 case GFC_ISYM_LBOUND
:
5553 case GFC_ISYM_UBOUND
:
5554 return gfc_walk_intrinsic_bound (ss
, expr
);
5556 case GFC_ISYM_TRANSFER
:
5557 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5560 /* This probably meant someone forgot to add an intrinsic to the above
5561 list(s) when they implemented it, or something's gone horribly
5569 gfc_conv_intrinsic_move_alloc (gfc_code
*code
)
5571 if (code
->ext
.actual
->expr
->rank
== 0)
5573 /* Scalar arguments: Generate pointer assignments. */
5574 gfc_expr
*from
, *to
;
5578 from
= code
->ext
.actual
->expr
;
5579 to
= code
->ext
.actual
->next
->expr
;
5581 gfc_start_block (&block
);
5583 if (to
->ts
.type
== BT_CLASS
)
5584 tmp
= gfc_trans_class_assign (to
, from
, EXEC_POINTER_ASSIGN
);
5586 tmp
= gfc_trans_pointer_assignment (to
, from
);
5587 gfc_add_expr_to_block (&block
, tmp
);
5589 if (from
->ts
.type
== BT_CLASS
)
5590 tmp
= gfc_trans_class_assign (from
, gfc_get_null_expr (NULL
),
5591 EXEC_POINTER_ASSIGN
);
5593 tmp
= gfc_trans_pointer_assignment (from
,
5594 gfc_get_null_expr (NULL
));
5595 gfc_add_expr_to_block (&block
, tmp
);
5597 return gfc_finish_block (&block
);
5600 /* Array arguments: Generate library code. */
5601 return gfc_trans_call (code
, false, NULL_TREE
, NULL_TREE
, false);
5605 #include "gt-fortran-trans-intrinsic.h"