1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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"
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 /* This maps fortran intrinsic math functions to external library or GCC
48 typedef struct GTY(()) gfc_intrinsic_map_t
{
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
53 /* Enum value from the "language-independent", aka C-centric, part
54 of gcc, or END_BUILTINS of no such value set. */
55 enum built_in_function code_r4
;
56 enum built_in_function code_r8
;
57 enum built_in_function code_r10
;
58 enum built_in_function code_r16
;
59 enum built_in_function code_c4
;
60 enum built_in_function code_c8
;
61 enum built_in_function code_c10
;
62 enum built_in_function code_c16
;
64 /* True if the naming pattern is to prepend "c" for complex and
65 append "f" for kind=4. False if the naming pattern is to
66 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
69 /* True if a complex version of the function exists. */
70 bool complex_available
;
72 /* True if the function should be marked const. */
75 /* The base library name of this function. */
78 /* Cache decls created for the various operand types. */
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 defines complex variants of all of the entries in mathbuiltins.def
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
96 false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
102 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
103 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
106 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
112 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
114 /* Functions built into gcc itself. */
115 #include "mathbuiltins.def"
117 /* Functions in libgfortran. */
118 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
121 LIB_FUNCTION (NONE
, NULL
, false)
125 #undef DEFINE_MATH_BUILTIN
126 #undef DEFINE_MATH_BUILTIN_C
128 /* Structure for storing components of a floating number to be used by
129 elemental functions to manipulate reals. */
132 tree arg
; /* Variable tree to view convert to integer. */
133 tree expn
; /* Variable tree to save exponent. */
134 tree frac
; /* Variable tree to save fraction. */
135 tree smask
; /* Constant tree of sign's mask. */
136 tree emask
; /* Constant tree of exponent's mask. */
137 tree fmask
; /* Constant tree of fraction's mask. */
138 tree edigits
; /* Constant tree of the number of exponent bits. */
139 tree fdigits
; /* Constant tree of the number of fraction bits. */
140 tree f1
; /* Constant tree of the f1 defined in the real model. */
141 tree bias
; /* Constant tree of the bias of exponent in the memory. */
142 tree type
; /* Type tree of arg1. */
143 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
147 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
149 /* Evaluate the arguments to an intrinsic function. The value
150 of NARGS may be less than the actual number of arguments in EXPR
151 to allow optional "KIND" arguments that are not included in the
152 generated code to be ignored. */
155 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
156 tree
*argarray
, int nargs
)
158 gfc_actual_arglist
*actual
;
160 gfc_intrinsic_arg
*formal
;
164 formal
= expr
->value
.function
.isym
->formal
;
165 actual
= expr
->value
.function
.actual
;
167 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
168 actual
= actual
->next
,
169 formal
= formal
? formal
->next
: NULL
)
173 /* Skip omitted optional arguments. */
180 /* Evaluate the parameter. This will substitute scalarized
181 references automatically. */
182 gfc_init_se (&argse
, se
);
184 if (e
->ts
.type
== BT_CHARACTER
)
186 gfc_conv_expr (&argse
, e
);
187 gfc_conv_string_parameter (&argse
);
188 argarray
[curr_arg
++] = argse
.string_length
;
189 gcc_assert (curr_arg
< nargs
);
192 gfc_conv_expr_val (&argse
, e
);
194 /* If an optional argument is itself an optional dummy argument,
195 check its presence and substitute a null if absent. */
196 if (e
->expr_type
== EXPR_VARIABLE
197 && e
->symtree
->n
.sym
->attr
.optional
200 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
202 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
203 gfc_add_block_to_block (&se
->post
, &argse
.post
);
204 argarray
[curr_arg
] = argse
.expr
;
208 /* Count the number of actual arguments to the intrinsic function EXPR
209 including any "hidden" string length arguments. */
212 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
215 gfc_actual_arglist
*actual
;
217 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
222 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
232 /* Conversions between different types are output by the frontend as
233 intrinsic functions. We implement these directly with inline code. */
236 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
242 nargs
= gfc_intrinsic_argument_list_length (expr
);
243 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
245 /* Evaluate all the arguments passed. Whilst we're only interested in the
246 first one here, there are other parts of the front-end that assume this
247 and will trigger an ICE if it's not the case. */
248 type
= gfc_typenode_for_spec (&expr
->ts
);
249 gcc_assert (expr
->value
.function
.actual
->expr
);
250 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
252 /* Conversion between character kinds involves a call to a library
254 if (expr
->ts
.type
== BT_CHARACTER
)
256 tree fndecl
, var
, addr
, tmp
;
258 if (expr
->ts
.kind
== 1
259 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
260 fndecl
= gfor_fndecl_convert_char4_to_char1
;
261 else if (expr
->ts
.kind
== 4
262 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
263 fndecl
= gfor_fndecl_convert_char1_to_char4
;
267 /* Create the variable storing the converted value. */
268 type
= gfc_get_pchar_type (expr
->ts
.kind
);
269 var
= gfc_create_var (type
, "str");
270 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
272 /* Call the library function that will perform the conversion. */
273 gcc_assert (nargs
>= 2);
274 tmp
= build_call_expr (fndecl
, 3, addr
, args
[0], args
[1]);
275 gfc_add_expr_to_block (&se
->pre
, tmp
);
277 /* Free the temporary afterwards. */
278 tmp
= gfc_call_free (var
);
279 gfc_add_expr_to_block (&se
->post
, tmp
);
282 se
->string_length
= args
[0];
287 /* Conversion from complex to non-complex involves taking the real
288 component of the value. */
289 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
290 && expr
->ts
.type
!= BT_COMPLEX
)
294 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
295 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
298 se
->expr
= convert (type
, args
[0]);
301 /* This is needed because the gcc backend only implements
302 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
303 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
304 Similarly for CEILING. */
307 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
314 argtype
= TREE_TYPE (arg
);
315 arg
= gfc_evaluate_now (arg
, pblock
);
317 intval
= convert (type
, arg
);
318 intval
= gfc_evaluate_now (intval
, pblock
);
320 tmp
= convert (argtype
, intval
);
321 cond
= fold_build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
323 tmp
= fold_build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
324 build_int_cst (type
, 1));
325 tmp
= fold_build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
330 /* Round to nearest integer, away from zero. */
333 build_round_expr (tree arg
, tree restype
)
338 int argprec
, resprec
;
340 argtype
= TREE_TYPE (arg
);
341 argprec
= TYPE_PRECISION (argtype
);
342 resprec
= TYPE_PRECISION (restype
);
344 /* Depending on the type of the result, choose the long int intrinsic
345 (lround family) or long long intrinsic (llround). We might also
346 need to convert the result afterwards. */
347 if (resprec
<= LONG_TYPE_SIZE
)
349 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
354 /* Now, depending on the argument type, we choose between intrinsics. */
355 if (argprec
== TYPE_PRECISION (float_type_node
))
356 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDF
: BUILT_IN_LROUNDF
];
357 else if (argprec
== TYPE_PRECISION (double_type_node
))
358 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUND
: BUILT_IN_LROUND
];
359 else if (argprec
== TYPE_PRECISION (long_double_type_node
))
360 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDL
: BUILT_IN_LROUNDL
];
364 return fold_convert (restype
, build_call_expr (fn
, 1, arg
));
368 /* Convert a real to an integer using a specific rounding mode.
369 Ideally we would just build the corresponding GENERIC node,
370 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
373 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
374 enum rounding_mode op
)
379 return build_fixbound_expr (pblock
, arg
, type
, 0);
383 return build_fixbound_expr (pblock
, arg
, type
, 1);
387 return build_round_expr (arg
, type
);
391 return fold_build1 (FIX_TRUNC_EXPR
, type
, arg
);
400 /* Round a real value using the specified rounding mode.
401 We use a temporary integer of that same kind size as the result.
402 Values larger than those that can be represented by this kind are
403 unchanged, as they will not be accurate enough to represent the
405 huge = HUGE (KIND (a))
406 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
410 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
421 kind
= expr
->ts
.kind
;
422 nargs
= gfc_intrinsic_argument_list_length (expr
);
425 /* We have builtin functions for some cases. */
468 /* Evaluate the argument. */
469 gcc_assert (expr
->value
.function
.actual
->expr
);
470 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
472 /* Use a builtin function if one exists. */
473 if (n
!= END_BUILTINS
)
475 tmp
= built_in_decls
[n
];
476 se
->expr
= build_call_expr (tmp
, 1, arg
[0]);
480 /* This code is probably redundant, but we'll keep it lying around just
482 type
= gfc_typenode_for_spec (&expr
->ts
);
483 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
485 /* Test if the value is too large to handle sensibly. */
486 gfc_set_model_kind (kind
);
488 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
489 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
490 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
491 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, arg
[0], tmp
);
493 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
494 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
495 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
[0], tmp
);
496 cond
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
497 itype
= gfc_get_int_type (kind
);
499 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
500 tmp
= convert (type
, tmp
);
501 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
, tmp
, arg
[0]);
506 /* Convert to an integer using the specified rounding mode. */
509 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
515 nargs
= gfc_intrinsic_argument_list_length (expr
);
516 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
518 /* Evaluate the argument, we process all arguments even though we only
519 use the first one for code generation purposes. */
520 type
= gfc_typenode_for_spec (&expr
->ts
);
521 gcc_assert (expr
->value
.function
.actual
->expr
);
522 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
524 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
526 /* Conversion to a different integer kind. */
527 se
->expr
= convert (type
, args
[0]);
531 /* Conversion from complex to non-complex involves taking the real
532 component of the value. */
533 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
534 && expr
->ts
.type
!= BT_COMPLEX
)
538 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
539 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
542 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
547 /* Get the imaginary component of a value. */
550 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
554 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
555 se
->expr
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
559 /* Get the complex conjugate of a value. */
562 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
566 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
567 se
->expr
= fold_build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
571 /* Initialize function decls for library functions. The external functions
572 are created as required. Builtin functions are added here. */
575 gfc_build_intrinsic_lib_fndecls (void)
577 gfc_intrinsic_map_t
*m
;
579 /* Add GCC builtin functions. */
580 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
582 if (m
->code_r4
!= END_BUILTINS
)
583 m
->real4_decl
= built_in_decls
[m
->code_r4
];
584 if (m
->code_r8
!= END_BUILTINS
)
585 m
->real8_decl
= built_in_decls
[m
->code_r8
];
586 if (m
->code_r10
!= END_BUILTINS
)
587 m
->real10_decl
= built_in_decls
[m
->code_r10
];
588 if (m
->code_r16
!= END_BUILTINS
)
589 m
->real16_decl
= built_in_decls
[m
->code_r16
];
590 if (m
->code_c4
!= END_BUILTINS
)
591 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
592 if (m
->code_c8
!= END_BUILTINS
)
593 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
594 if (m
->code_c10
!= END_BUILTINS
)
595 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
596 if (m
->code_c16
!= END_BUILTINS
)
597 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
602 /* Create a fndecl for a simple intrinsic library function. */
605 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
610 gfc_actual_arglist
*actual
;
613 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
616 if (ts
->type
== BT_REAL
)
621 pdecl
= &m
->real4_decl
;
624 pdecl
= &m
->real8_decl
;
627 pdecl
= &m
->real10_decl
;
630 pdecl
= &m
->real16_decl
;
636 else if (ts
->type
== BT_COMPLEX
)
638 gcc_assert (m
->complex_available
);
643 pdecl
= &m
->complex4_decl
;
646 pdecl
= &m
->complex8_decl
;
649 pdecl
= &m
->complex10_decl
;
652 pdecl
= &m
->complex16_decl
;
667 snprintf (name
, sizeof (name
), "%s%s%s",
668 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
669 else if (ts
->kind
== 8)
670 snprintf (name
, sizeof (name
), "%s%s",
671 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
674 gcc_assert (ts
->kind
== 10 || ts
->kind
== 16);
675 snprintf (name
, sizeof (name
), "%s%s%s",
676 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
681 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
682 ts
->type
== BT_COMPLEX
? 'c' : 'r',
686 argtypes
= NULL_TREE
;
687 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
689 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
690 argtypes
= gfc_chainon_list (argtypes
, type
);
692 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
693 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
694 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
696 /* Mark the decl as external. */
697 DECL_EXTERNAL (fndecl
) = 1;
698 TREE_PUBLIC (fndecl
) = 1;
700 /* Mark it __attribute__((const)), if possible. */
701 TREE_READONLY (fndecl
) = m
->is_constant
;
703 rest_of_decl_compilation (fndecl
, 1, 0);
710 /* Convert an intrinsic function into an external or builtin call. */
713 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
715 gfc_intrinsic_map_t
*m
;
719 unsigned int num_args
;
722 id
= expr
->value
.function
.isym
->id
;
723 /* Find the entry for this function. */
724 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
730 if (m
->id
== GFC_ISYM_NONE
)
732 internal_error ("Intrinsic function %s(%d) not recognized",
733 expr
->value
.function
.name
, id
);
736 /* Get the decl and generate the call. */
737 num_args
= gfc_intrinsic_argument_list_length (expr
);
738 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
740 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
741 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
742 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
744 fndecl
= build_addr (fndecl
, current_function_decl
);
745 se
->expr
= build_call_array (rettype
, fndecl
, num_args
, args
);
749 /* If bounds-checking is enabled, create code to verify at runtime that the
750 string lengths for both expressions are the same (needed for e.g. MERGE).
751 If bounds-checking is not enabled, does nothing. */
754 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
755 tree a
, tree b
, stmtblock_t
* target
)
760 /* If bounds-checking is disabled, do nothing. */
761 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
764 /* Compare the two string lengths. */
765 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, a
, b
);
767 /* Output the runtime-check. */
768 name
= gfc_build_cstring_const (intr_name
);
769 name
= gfc_build_addr_expr (pchar_type_node
, name
);
770 gfc_trans_runtime_check (true, false, cond
, target
, where
,
771 "Unequal character lengths (%ld/%ld) in %s",
772 fold_convert (long_integer_type_node
, a
),
773 fold_convert (long_integer_type_node
, b
), name
);
777 /* The EXPONENT(s) intrinsic function is translated into
784 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
786 tree arg
, type
, res
, tmp
;
789 switch (expr
->value
.function
.actual
->expr
->ts
.kind
)
792 frexp
= BUILT_IN_FREXPF
;
795 frexp
= BUILT_IN_FREXP
;
799 frexp
= BUILT_IN_FREXPL
;
805 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
807 res
= gfc_create_var (integer_type_node
, NULL
);
808 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
809 gfc_build_addr_expr (NULL_TREE
, res
));
810 gfc_add_expr_to_block (&se
->pre
, tmp
);
812 type
= gfc_typenode_for_spec (&expr
->ts
);
813 se
->expr
= fold_convert (type
, res
);
816 /* Evaluate a single upper or lower bound. */
817 /* TODO: bound intrinsic generates way too much unnecessary code. */
820 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
822 gfc_actual_arglist
*arg
;
823 gfc_actual_arglist
*arg2
;
828 tree cond
, cond1
, cond2
, cond3
, cond4
, size
;
836 arg
= expr
->value
.function
.actual
;
841 /* Create an implicit second parameter from the loop variable. */
842 gcc_assert (!arg2
->expr
);
843 gcc_assert (se
->loop
->dimen
== 1);
844 gcc_assert (se
->ss
->expr
== expr
);
845 gfc_advance_se_ss_chain (se
);
846 bound
= se
->loop
->loopvar
[0];
847 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
852 /* use the passed argument. */
853 gcc_assert (arg
->next
->expr
);
854 gfc_init_se (&argse
, NULL
);
855 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
856 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
858 /* Convert from one based to zero based. */
859 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
863 /* TODO: don't re-evaluate the descriptor on each iteration. */
864 /* Get a descriptor for the first parameter. */
865 ss
= gfc_walk_expr (arg
->expr
);
866 gcc_assert (ss
!= gfc_ss_terminator
);
867 gfc_init_se (&argse
, NULL
);
868 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
869 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
870 gfc_add_block_to_block (&se
->post
, &argse
.post
);
874 if (INTEGER_CST_P (bound
))
878 hi
= TREE_INT_CST_HIGH (bound
);
879 low
= TREE_INT_CST_LOW (bound
);
880 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
881 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
882 "dimension index", upper
? "UBOUND" : "LBOUND",
887 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
889 bound
= gfc_evaluate_now (bound
, &se
->pre
);
890 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
891 bound
, build_int_cst (TREE_TYPE (bound
), 0));
892 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
893 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
894 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
895 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
900 ubound
= gfc_conv_descriptor_ubound (desc
, bound
);
901 lbound
= gfc_conv_descriptor_lbound (desc
, bound
);
903 /* Follow any component references. */
904 if (arg
->expr
->expr_type
== EXPR_VARIABLE
905 || arg
->expr
->expr_type
== EXPR_CONSTANT
)
907 as
= arg
->expr
->symtree
->n
.sym
->as
;
908 for (ref
= arg
->expr
->ref
; ref
; ref
= ref
->next
)
913 as
= ref
->u
.c
.component
->as
;
921 switch (ref
->u
.ar
.type
)
940 /* 13.14.53: Result value for LBOUND
942 Case (i): For an array section or for an array expression other than a
943 whole array or array structure component, LBOUND(ARRAY, DIM)
944 has the value 1. For a whole array or array structure
945 component, LBOUND(ARRAY, DIM) has the value:
946 (a) equal to the lower bound for subscript DIM of ARRAY if
947 dimension DIM of ARRAY does not have extent zero
948 or if ARRAY is an assumed-size array of rank DIM,
951 13.14.113: Result value for UBOUND
953 Case (i): For an array section or for an array expression other than a
954 whole array or array structure component, UBOUND(ARRAY, DIM)
955 has the value equal to the number of elements in the given
956 dimension; otherwise, it has a value equal to the upper bound
957 for subscript DIM of ARRAY if dimension DIM of ARRAY does
958 not have size zero and has value zero if dimension DIM has
963 tree stride
= gfc_conv_descriptor_stride (desc
, bound
);
965 cond1
= fold_build2 (GE_EXPR
, boolean_type_node
, ubound
, lbound
);
966 cond2
= fold_build2 (LE_EXPR
, boolean_type_node
, ubound
, lbound
);
968 cond3
= fold_build2 (GE_EXPR
, boolean_type_node
, stride
,
969 gfc_index_zero_node
);
970 cond3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond3
, cond1
);
972 cond4
= fold_build2 (LT_EXPR
, boolean_type_node
, stride
,
973 gfc_index_zero_node
);
978 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
980 cond5
= fold_build2 (EQ_EXPR
, boolean_type_node
, gfc_index_one_node
, lbound
);
981 cond5
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond4
, cond5
);
983 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond5
);
985 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
986 ubound
, gfc_index_zero_node
);
990 if (as
->type
== AS_ASSUMED_SIZE
)
991 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, bound
,
992 build_int_cst (TREE_TYPE (bound
),
993 arg
->expr
->rank
- 1));
995 cond
= boolean_false_node
;
997 cond1
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
998 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond1
);
1000 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1001 lbound
, gfc_index_one_node
);
1008 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
1009 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
1010 gfc_index_one_node
);
1011 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
1012 gfc_index_zero_node
);
1015 se
->expr
= gfc_index_one_node
;
1018 type
= gfc_typenode_for_spec (&expr
->ts
);
1019 se
->expr
= convert (type
, se
->expr
);
1024 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1029 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1031 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1035 se
->expr
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg
), arg
);
1039 switch (expr
->ts
.kind
)
1054 se
->expr
= build_call_expr (built_in_decls
[n
], 1, arg
);
1063 /* Create a complex value from one or two real components. */
1066 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1072 unsigned int num_args
;
1074 num_args
= gfc_intrinsic_argument_list_length (expr
);
1075 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1077 type
= gfc_typenode_for_spec (&expr
->ts
);
1078 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1079 real
= convert (TREE_TYPE (type
), args
[0]);
1081 imag
= convert (TREE_TYPE (type
), args
[1]);
1082 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1084 imag
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (args
[0])),
1086 imag
= convert (TREE_TYPE (type
), imag
);
1089 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1091 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
1094 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1095 MODULO(A, P) = A - FLOOR (A / P) * P */
1096 /* TODO: MOD(x, 0) */
1099 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1110 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1112 switch (expr
->ts
.type
)
1115 /* Integer case is easy, we've got a builtin op. */
1116 type
= TREE_TYPE (args
[0]);
1119 se
->expr
= fold_build2 (FLOOR_MOD_EXPR
, type
, args
[0], args
[1]);
1121 se
->expr
= fold_build2 (TRUNC_MOD_EXPR
, type
, args
[0], args
[1]);
1126 /* Check if we have a builtin fmod. */
1127 switch (expr
->ts
.kind
)
1146 /* Use it if it exists. */
1147 if (n
!= END_BUILTINS
)
1149 tmp
= build_addr (built_in_decls
[n
], current_function_decl
);
1150 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls
[n
])),
1156 type
= TREE_TYPE (args
[0]);
1158 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1159 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1162 modulo = arg - floor (arg/arg2) * arg2, so
1163 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1165 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1166 thereby avoiding another division and retaining the accuracy
1167 of the builtin function. */
1168 if (n
!= END_BUILTINS
&& modulo
)
1170 tree zero
= gfc_build_const (type
, integer_zero_node
);
1171 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1172 test
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[0], zero
);
1173 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[1], zero
);
1174 test2
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
1175 test
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, zero
);
1176 test
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1177 test
= gfc_evaluate_now (test
, &se
->pre
);
1178 se
->expr
= fold_build3 (COND_EXPR
, type
, test
,
1179 fold_build2 (PLUS_EXPR
, type
, tmp
, args
[1]),
1184 /* If we do not have a built_in fmod, the calculation is going to
1185 have to be done longhand. */
1186 tmp
= fold_build2 (RDIV_EXPR
, type
, args
[0], args
[1]);
1188 /* Test if the value is too large to handle sensibly. */
1189 gfc_set_model_kind (expr
->ts
.kind
);
1191 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1192 ikind
= expr
->ts
.kind
;
1195 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1196 ikind
= gfc_max_integer_kind
;
1198 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1199 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1200 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
1202 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1203 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1204 test
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
1205 test2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1207 itype
= gfc_get_int_type (ikind
);
1209 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1211 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1212 tmp
= convert (type
, tmp
);
1213 tmp
= fold_build3 (COND_EXPR
, type
, test2
, tmp
, args
[0]);
1214 tmp
= fold_build2 (MULT_EXPR
, type
, tmp
, args
[1]);
1215 se
->expr
= fold_build2 (MINUS_EXPR
, type
, args
[0], tmp
);
1224 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1227 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1235 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1236 type
= TREE_TYPE (args
[0]);
1238 val
= fold_build2 (MINUS_EXPR
, type
, args
[0], args
[1]);
1239 val
= gfc_evaluate_now (val
, &se
->pre
);
1241 zero
= gfc_build_const (type
, integer_zero_node
);
1242 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
1243 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, zero
, val
);
1247 /* SIGN(A, B) is absolute value of A times sign of B.
1248 The real value versions use library functions to ensure the correct
1249 handling of negative zero. Integer case implemented as:
1250 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1254 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1260 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1261 if (expr
->ts
.type
== BT_REAL
)
1263 switch (expr
->ts
.kind
)
1266 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
1269 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
1273 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
1278 se
->expr
= build_call_expr (tmp
, 2, args
[0], args
[1]);
1282 /* Having excluded floating point types, we know we are now dealing
1283 with signed integer types. */
1284 type
= TREE_TYPE (args
[0]);
1286 /* Args[0] is used multiple times below. */
1287 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1289 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1290 the signs of A and B are the same, and of all ones if they differ. */
1291 tmp
= fold_build2 (BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1292 tmp
= fold_build2 (RSHIFT_EXPR
, type
, tmp
,
1293 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1294 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1296 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1297 is all ones (i.e. -1). */
1298 se
->expr
= fold_build2 (BIT_XOR_EXPR
, type
,
1299 fold_build2 (PLUS_EXPR
, type
, args
[0], tmp
),
1304 /* Test for the presence of an optional argument. */
1307 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1311 arg
= expr
->value
.function
.actual
->expr
;
1312 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1313 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1314 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1318 /* Calculate the double precision product of two single precision values. */
1321 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1326 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1328 /* Convert the args to double precision before multiplying. */
1329 type
= gfc_typenode_for_spec (&expr
->ts
);
1330 args
[0] = convert (type
, args
[0]);
1331 args
[1] = convert (type
, args
[1]);
1332 se
->expr
= fold_build2 (MULT_EXPR
, type
, args
[0], args
[1]);
1336 /* Return a length one character string containing an ascii character. */
1339 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1344 unsigned int num_args
;
1346 num_args
= gfc_intrinsic_argument_list_length (expr
);
1347 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
1349 type
= gfc_get_char_type (expr
->ts
.kind
);
1350 var
= gfc_create_var (type
, "char");
1352 arg
[0] = fold_build1 (NOP_EXPR
, type
, arg
[0]);
1353 gfc_add_modify (&se
->pre
, var
, arg
[0]);
1354 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1355 se
->string_length
= integer_one_node
;
1360 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1368 unsigned int num_args
;
1370 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1371 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1373 var
= gfc_create_var (pchar_type_node
, "pstr");
1374 len
= gfc_create_var (gfc_get_int_type (8), "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_ctime
, current_function_decl
);
1381 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1382 fndecl
, num_args
, args
);
1383 gfc_add_expr_to_block (&se
->pre
, tmp
);
1385 /* Free the temporary afterwards, if necessary. */
1386 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1387 len
, build_int_cst (TREE_TYPE (len
), 0));
1388 tmp
= gfc_call_free (var
);
1389 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1390 gfc_add_expr_to_block (&se
->post
, tmp
);
1393 se
->string_length
= len
;
1398 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1406 unsigned int num_args
;
1408 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1409 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1411 var
= gfc_create_var (pchar_type_node
, "pstr");
1412 len
= gfc_create_var (gfc_get_int_type (4), "len");
1414 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1415 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1416 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1418 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1419 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1420 fndecl
, num_args
, args
);
1421 gfc_add_expr_to_block (&se
->pre
, tmp
);
1423 /* Free the temporary afterwards, if necessary. */
1424 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1425 len
, build_int_cst (TREE_TYPE (len
), 0));
1426 tmp
= gfc_call_free (var
);
1427 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1428 gfc_add_expr_to_block (&se
->post
, tmp
);
1431 se
->string_length
= len
;
1435 /* Return a character string containing the tty name. */
1438 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1446 unsigned int num_args
;
1448 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1449 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1451 var
= gfc_create_var (pchar_type_node
, "pstr");
1452 len
= gfc_create_var (gfc_get_int_type (4), "len");
1454 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1455 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1456 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1458 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1459 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1460 fndecl
, num_args
, args
);
1461 gfc_add_expr_to_block (&se
->pre
, tmp
);
1463 /* Free the temporary afterwards, if necessary. */
1464 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1465 len
, build_int_cst (TREE_TYPE (len
), 0));
1466 tmp
= gfc_call_free (var
);
1467 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1468 gfc_add_expr_to_block (&se
->post
, tmp
);
1471 se
->string_length
= len
;
1475 /* Get the minimum/maximum value of all the parameters.
1476 minmax (a1, a2, a3, ...)
1479 if (a2 .op. mvar || isnan(mvar))
1481 if (a3 .op. mvar || isnan(mvar))
1488 /* TODO: Mismatching types can occur when specific names are used.
1489 These should be handled during resolution. */
1491 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1499 gfc_actual_arglist
*argexpr
;
1500 unsigned int i
, nargs
;
1502 nargs
= gfc_intrinsic_argument_list_length (expr
);
1503 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
1505 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1506 type
= gfc_typenode_for_spec (&expr
->ts
);
1508 argexpr
= expr
->value
.function
.actual
;
1509 if (TREE_TYPE (args
[0]) != type
)
1510 args
[0] = convert (type
, args
[0]);
1511 /* Only evaluate the argument once. */
1512 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
1513 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1515 mvar
= gfc_create_var (type
, "M");
1516 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
1517 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1523 /* Handle absent optional arguments by ignoring the comparison. */
1524 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1525 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1526 && TREE_CODE (val
) == INDIRECT_REF
)
1528 (NE_EXPR
, boolean_type_node
, TREE_OPERAND (val
, 0),
1529 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1534 /* Only evaluate the argument once. */
1535 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1536 val
= gfc_evaluate_now (val
, &se
->pre
);
1539 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1541 tmp
= fold_build2 (op
, boolean_type_node
, convert (type
, val
), mvar
);
1543 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1544 __builtin_isnan might be made dependent on that module being loaded,
1545 to help performance of programs that don't rely on IEEE semantics. */
1546 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
1548 isnan
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, mvar
);
1549 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
,
1550 fold_convert (boolean_type_node
, isnan
));
1552 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, build_empty_stmt ());
1554 if (cond
!= NULL_TREE
)
1555 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1557 gfc_add_expr_to_block (&se
->pre
, tmp
);
1558 argexpr
= argexpr
->next
;
1564 /* Generate library calls for MIN and MAX intrinsics for character
1567 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
1570 tree var
, len
, fndecl
, tmp
, cond
, function
;
1573 nargs
= gfc_intrinsic_argument_list_length (expr
);
1574 args
= (tree
*) alloca (sizeof (tree
) * (nargs
+ 4));
1575 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
1577 /* Create the result variables. */
1578 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1579 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
1580 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
1581 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
1582 args
[2] = build_int_cst (NULL_TREE
, op
);
1583 args
[3] = build_int_cst (NULL_TREE
, nargs
/ 2);
1585 if (expr
->ts
.kind
== 1)
1586 function
= gfor_fndecl_string_minmax
;
1587 else if (expr
->ts
.kind
== 4)
1588 function
= gfor_fndecl_string_minmax_char4
;
1592 /* Make the function call. */
1593 fndecl
= build_addr (function
, current_function_decl
);
1594 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
1596 gfc_add_expr_to_block (&se
->pre
, tmp
);
1598 /* Free the temporary afterwards, if necessary. */
1599 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1600 len
, build_int_cst (TREE_TYPE (len
), 0));
1601 tmp
= gfc_call_free (var
);
1602 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1603 gfc_add_expr_to_block (&se
->post
, tmp
);
1606 se
->string_length
= len
;
1610 /* Create a symbol node for this intrinsic. The symbol from the frontend
1611 has the generic name. */
1614 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1618 /* TODO: Add symbols for intrinsic function to the global namespace. */
1619 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1620 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1623 sym
->attr
.external
= 1;
1624 sym
->attr
.function
= 1;
1625 sym
->attr
.always_explicit
= 1;
1626 sym
->attr
.proc
= PROC_INTRINSIC
;
1627 sym
->attr
.flavor
= FL_PROCEDURE
;
1631 sym
->attr
.dimension
= 1;
1632 sym
->as
= gfc_get_array_spec ();
1633 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1634 sym
->as
->rank
= expr
->rank
;
1637 /* TODO: proper argument lists for external intrinsics. */
1641 /* Generate a call to an external intrinsic function. */
1643 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1648 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1651 gcc_assert (expr
->rank
> 0);
1653 gcc_assert (expr
->rank
== 0);
1655 sym
= gfc_get_symbol_for_expr (expr
);
1657 /* Calls to libgfortran_matmul need to be appended special arguments,
1658 to be able to call the BLAS ?gemm functions if required and possible. */
1659 append_args
= NULL_TREE
;
1660 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1661 && sym
->ts
.type
!= BT_LOGICAL
)
1663 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1665 if (gfc_option
.flag_external_blas
1666 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1667 && (sym
->ts
.kind
== gfc_default_real_kind
1668 || sym
->ts
.kind
== gfc_default_double_kind
))
1672 if (sym
->ts
.type
== BT_REAL
)
1674 if (sym
->ts
.kind
== gfc_default_real_kind
)
1675 gemm_fndecl
= gfor_fndecl_sgemm
;
1677 gemm_fndecl
= gfor_fndecl_dgemm
;
1681 if (sym
->ts
.kind
== gfc_default_real_kind
)
1682 gemm_fndecl
= gfor_fndecl_cgemm
;
1684 gemm_fndecl
= gfor_fndecl_zgemm
;
1687 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 1));
1688 append_args
= gfc_chainon_list
1689 (append_args
, build_int_cst
1690 (cint
, gfc_option
.blas_matmul_limit
));
1691 append_args
= gfc_chainon_list (append_args
,
1692 gfc_build_addr_expr (NULL_TREE
,
1697 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 0));
1698 append_args
= gfc_chainon_list (append_args
, build_int_cst (cint
, 0));
1699 append_args
= gfc_chainon_list (append_args
, null_pointer_node
);
1703 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
1707 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1727 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1736 gfc_actual_arglist
*actual
;
1743 gfc_conv_intrinsic_funcall (se
, expr
);
1747 actual
= expr
->value
.function
.actual
;
1748 type
= gfc_typenode_for_spec (&expr
->ts
);
1749 /* Initialize the result. */
1750 resvar
= gfc_create_var (type
, "test");
1752 tmp
= convert (type
, boolean_true_node
);
1754 tmp
= convert (type
, boolean_false_node
);
1755 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1757 /* Walk the arguments. */
1758 arrayss
= gfc_walk_expr (actual
->expr
);
1759 gcc_assert (arrayss
!= gfc_ss_terminator
);
1761 /* Initialize the scalarizer. */
1762 gfc_init_loopinfo (&loop
);
1763 exit_label
= gfc_build_label_decl (NULL_TREE
);
1764 TREE_USED (exit_label
) = 1;
1765 gfc_add_ss_to_loop (&loop
, arrayss
);
1767 /* Initialize the loop. */
1768 gfc_conv_ss_startstride (&loop
);
1769 gfc_conv_loop_setup (&loop
, &expr
->where
);
1771 gfc_mark_ss_chain_used (arrayss
, 1);
1772 /* Generate the loop body. */
1773 gfc_start_scalarized_body (&loop
, &body
);
1775 /* If the condition matches then set the return value. */
1776 gfc_start_block (&block
);
1778 tmp
= convert (type
, boolean_false_node
);
1780 tmp
= convert (type
, boolean_true_node
);
1781 gfc_add_modify (&block
, resvar
, tmp
);
1783 /* And break out of the loop. */
1784 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1785 gfc_add_expr_to_block (&block
, tmp
);
1787 found
= gfc_finish_block (&block
);
1789 /* Check this element. */
1790 gfc_init_se (&arrayse
, NULL
);
1791 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1792 arrayse
.ss
= arrayss
;
1793 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1795 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1796 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1797 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1798 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
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 /* Add the exit label. */
1805 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1806 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1808 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1809 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1810 gfc_cleanup_loop (&loop
);
1815 /* COUNT(A) = Number of true elements in A. */
1817 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1824 gfc_actual_arglist
*actual
;
1830 gfc_conv_intrinsic_funcall (se
, expr
);
1834 actual
= expr
->value
.function
.actual
;
1836 type
= gfc_typenode_for_spec (&expr
->ts
);
1837 /* Initialize the result. */
1838 resvar
= gfc_create_var (type
, "count");
1839 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
1841 /* Walk the arguments. */
1842 arrayss
= gfc_walk_expr (actual
->expr
);
1843 gcc_assert (arrayss
!= gfc_ss_terminator
);
1845 /* Initialize the scalarizer. */
1846 gfc_init_loopinfo (&loop
);
1847 gfc_add_ss_to_loop (&loop
, arrayss
);
1849 /* Initialize the loop. */
1850 gfc_conv_ss_startstride (&loop
);
1851 gfc_conv_loop_setup (&loop
, &expr
->where
);
1853 gfc_mark_ss_chain_used (arrayss
, 1);
1854 /* Generate the loop body. */
1855 gfc_start_scalarized_body (&loop
, &body
);
1857 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (resvar
),
1858 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
1859 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1861 gfc_init_se (&arrayse
, NULL
);
1862 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1863 arrayse
.ss
= arrayss
;
1864 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1865 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1867 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1868 gfc_add_expr_to_block (&body
, tmp
);
1869 gfc_add_block_to_block (&body
, &arrayse
.post
);
1871 gfc_trans_scalarizing_loops (&loop
, &body
);
1873 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1874 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1875 gfc_cleanup_loop (&loop
);
1880 /* Inline implementation of the sum and product intrinsics. */
1882 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1890 gfc_actual_arglist
*actual
;
1895 gfc_expr
*arrayexpr
;
1900 gfc_conv_intrinsic_funcall (se
, expr
);
1904 type
= gfc_typenode_for_spec (&expr
->ts
);
1905 /* Initialize the result. */
1906 resvar
= gfc_create_var (type
, "val");
1907 if (op
== PLUS_EXPR
)
1908 tmp
= gfc_build_const (type
, integer_zero_node
);
1910 tmp
= gfc_build_const (type
, integer_one_node
);
1912 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1914 /* Walk the arguments. */
1915 actual
= expr
->value
.function
.actual
;
1916 arrayexpr
= actual
->expr
;
1917 arrayss
= gfc_walk_expr (arrayexpr
);
1918 gcc_assert (arrayss
!= gfc_ss_terminator
);
1920 actual
= actual
->next
->next
;
1921 gcc_assert (actual
);
1922 maskexpr
= actual
->expr
;
1923 if (maskexpr
&& maskexpr
->rank
!= 0)
1925 maskss
= gfc_walk_expr (maskexpr
);
1926 gcc_assert (maskss
!= gfc_ss_terminator
);
1931 /* Initialize the scalarizer. */
1932 gfc_init_loopinfo (&loop
);
1933 gfc_add_ss_to_loop (&loop
, arrayss
);
1935 gfc_add_ss_to_loop (&loop
, maskss
);
1937 /* Initialize the loop. */
1938 gfc_conv_ss_startstride (&loop
);
1939 gfc_conv_loop_setup (&loop
, &expr
->where
);
1941 gfc_mark_ss_chain_used (arrayss
, 1);
1943 gfc_mark_ss_chain_used (maskss
, 1);
1944 /* Generate the loop body. */
1945 gfc_start_scalarized_body (&loop
, &body
);
1947 /* If we have a mask, only add this element if the mask is set. */
1950 gfc_init_se (&maskse
, NULL
);
1951 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1953 gfc_conv_expr_val (&maskse
, maskexpr
);
1954 gfc_add_block_to_block (&body
, &maskse
.pre
);
1956 gfc_start_block (&block
);
1959 gfc_init_block (&block
);
1961 /* Do the actual summation/product. */
1962 gfc_init_se (&arrayse
, NULL
);
1963 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1964 arrayse
.ss
= arrayss
;
1965 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1966 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1968 tmp
= fold_build2 (op
, type
, resvar
, arrayse
.expr
);
1969 gfc_add_modify (&block
, resvar
, tmp
);
1970 gfc_add_block_to_block (&block
, &arrayse
.post
);
1974 /* We enclose the above in if (mask) {...} . */
1975 tmp
= gfc_finish_block (&block
);
1977 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1980 tmp
= gfc_finish_block (&block
);
1981 gfc_add_expr_to_block (&body
, tmp
);
1983 gfc_trans_scalarizing_loops (&loop
, &body
);
1985 /* For a scalar mask, enclose the loop in an if statement. */
1986 if (maskexpr
&& maskss
== NULL
)
1988 gfc_init_se (&maskse
, NULL
);
1989 gfc_conv_expr_val (&maskse
, maskexpr
);
1990 gfc_init_block (&block
);
1991 gfc_add_block_to_block (&block
, &loop
.pre
);
1992 gfc_add_block_to_block (&block
, &loop
.post
);
1993 tmp
= gfc_finish_block (&block
);
1995 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1996 gfc_add_expr_to_block (&block
, tmp
);
1997 gfc_add_block_to_block (&se
->pre
, &block
);
2001 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2002 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2005 gfc_cleanup_loop (&loop
);
2011 /* Inline implementation of the dot_product intrinsic. This function
2012 is based on gfc_conv_intrinsic_arith (the previous function). */
2014 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2022 gfc_actual_arglist
*actual
;
2023 gfc_ss
*arrayss1
, *arrayss2
;
2024 gfc_se arrayse1
, arrayse2
;
2025 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2027 type
= gfc_typenode_for_spec (&expr
->ts
);
2029 /* Initialize the result. */
2030 resvar
= gfc_create_var (type
, "val");
2031 if (expr
->ts
.type
== BT_LOGICAL
)
2032 tmp
= build_int_cst (type
, 0);
2034 tmp
= gfc_build_const (type
, integer_zero_node
);
2036 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2038 /* Walk argument #1. */
2039 actual
= expr
->value
.function
.actual
;
2040 arrayexpr1
= actual
->expr
;
2041 arrayss1
= gfc_walk_expr (arrayexpr1
);
2042 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2044 /* Walk argument #2. */
2045 actual
= actual
->next
;
2046 arrayexpr2
= actual
->expr
;
2047 arrayss2
= gfc_walk_expr (arrayexpr2
);
2048 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2050 /* Initialize the scalarizer. */
2051 gfc_init_loopinfo (&loop
);
2052 gfc_add_ss_to_loop (&loop
, arrayss1
);
2053 gfc_add_ss_to_loop (&loop
, arrayss2
);
2055 /* Initialize the loop. */
2056 gfc_conv_ss_startstride (&loop
);
2057 gfc_conv_loop_setup (&loop
, &expr
->where
);
2059 gfc_mark_ss_chain_used (arrayss1
, 1);
2060 gfc_mark_ss_chain_used (arrayss2
, 1);
2062 /* Generate the loop body. */
2063 gfc_start_scalarized_body (&loop
, &body
);
2064 gfc_init_block (&block
);
2066 /* Make the tree expression for [conjg(]array1[)]. */
2067 gfc_init_se (&arrayse1
, NULL
);
2068 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2069 arrayse1
.ss
= arrayss1
;
2070 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2071 if (expr
->ts
.type
== BT_COMPLEX
)
2072 arrayse1
.expr
= fold_build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
2073 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2075 /* Make the tree expression for array2. */
2076 gfc_init_se (&arrayse2
, NULL
);
2077 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2078 arrayse2
.ss
= arrayss2
;
2079 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2080 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2082 /* Do the actual product and sum. */
2083 if (expr
->ts
.type
== BT_LOGICAL
)
2085 tmp
= fold_build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2086 tmp
= fold_build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2090 tmp
= fold_build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2091 tmp
= fold_build2 (PLUS_EXPR
, type
, resvar
, tmp
);
2093 gfc_add_modify (&block
, resvar
, tmp
);
2095 /* Finish up the loop block and the loop. */
2096 tmp
= gfc_finish_block (&block
);
2097 gfc_add_expr_to_block (&body
, tmp
);
2099 gfc_trans_scalarizing_loops (&loop
, &body
);
2100 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2101 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2102 gfc_cleanup_loop (&loop
);
2109 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2113 stmtblock_t ifblock
;
2114 stmtblock_t elseblock
;
2122 gfc_actual_arglist
*actual
;
2127 gfc_expr
*arrayexpr
;
2134 gfc_conv_intrinsic_funcall (se
, expr
);
2138 /* Initialize the result. */
2139 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2140 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2141 type
= gfc_typenode_for_spec (&expr
->ts
);
2143 /* Walk the arguments. */
2144 actual
= expr
->value
.function
.actual
;
2145 arrayexpr
= actual
->expr
;
2146 arrayss
= gfc_walk_expr (arrayexpr
);
2147 gcc_assert (arrayss
!= gfc_ss_terminator
);
2149 actual
= actual
->next
->next
;
2150 gcc_assert (actual
);
2151 maskexpr
= actual
->expr
;
2152 if (maskexpr
&& maskexpr
->rank
!= 0)
2154 maskss
= gfc_walk_expr (maskexpr
);
2155 gcc_assert (maskss
!= gfc_ss_terminator
);
2160 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2161 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2162 switch (arrayexpr
->ts
.type
)
2165 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
2166 arrayexpr
->ts
.kind
, 0);
2170 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2171 arrayexpr
->ts
.kind
);
2178 /* We start with the most negative possible value for MAXLOC, and the most
2179 positive possible value for MINLOC. The most negative possible value is
2180 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2181 possible value is HUGE in both cases. */
2183 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2184 gfc_add_modify (&se
->pre
, limit
, tmp
);
2186 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2187 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2188 build_int_cst (type
, 1));
2190 /* Initialize the scalarizer. */
2191 gfc_init_loopinfo (&loop
);
2192 gfc_add_ss_to_loop (&loop
, arrayss
);
2194 gfc_add_ss_to_loop (&loop
, maskss
);
2196 /* Initialize the loop. */
2197 gfc_conv_ss_startstride (&loop
);
2198 gfc_conv_loop_setup (&loop
, &expr
->where
);
2200 gcc_assert (loop
.dimen
== 1);
2202 /* Initialize the position to zero, following Fortran 2003. We are free
2203 to do this because Fortran 95 allows the result of an entirely false
2204 mask to be processor dependent. */
2205 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
2207 gfc_mark_ss_chain_used (arrayss
, 1);
2209 gfc_mark_ss_chain_used (maskss
, 1);
2210 /* Generate the loop body. */
2211 gfc_start_scalarized_body (&loop
, &body
);
2213 /* If we have a mask, only check this element if the mask is set. */
2216 gfc_init_se (&maskse
, NULL
);
2217 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2219 gfc_conv_expr_val (&maskse
, maskexpr
);
2220 gfc_add_block_to_block (&body
, &maskse
.pre
);
2222 gfc_start_block (&block
);
2225 gfc_init_block (&block
);
2227 /* Compare with the current limit. */
2228 gfc_init_se (&arrayse
, NULL
);
2229 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2230 arrayse
.ss
= arrayss
;
2231 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2232 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2234 /* We do the following if this is a more extreme value. */
2235 gfc_start_block (&ifblock
);
2237 /* Assign the value to the limit... */
2238 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2240 /* Remember where we are. An offset must be added to the loop
2241 counter to obtain the required position. */
2243 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2244 gfc_index_one_node
, loop
.from
[0]);
2246 tmp
= gfc_index_one_node
;
2248 gfc_add_modify (&block
, offset
, tmp
);
2250 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2251 loop
.loopvar
[0], offset
);
2252 gfc_add_modify (&ifblock
, pos
, tmp
);
2254 ifbody
= gfc_finish_block (&ifblock
);
2256 /* If it is a more extreme value or pos is still zero and the value
2257 equal to the limit. */
2258 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2259 fold_build2 (EQ_EXPR
, boolean_type_node
,
2260 pos
, gfc_index_zero_node
),
2261 fold_build2 (EQ_EXPR
, boolean_type_node
,
2262 arrayse
.expr
, limit
));
2263 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2264 fold_build2 (op
, boolean_type_node
,
2265 arrayse
.expr
, limit
), tmp
);
2266 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2267 gfc_add_expr_to_block (&block
, tmp
);
2271 /* We enclose the above in if (mask) {...}. */
2272 tmp
= gfc_finish_block (&block
);
2274 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2277 tmp
= gfc_finish_block (&block
);
2278 gfc_add_expr_to_block (&body
, tmp
);
2280 gfc_trans_scalarizing_loops (&loop
, &body
);
2282 /* For a scalar mask, enclose the loop in an if statement. */
2283 if (maskexpr
&& maskss
== NULL
)
2285 gfc_init_se (&maskse
, NULL
);
2286 gfc_conv_expr_val (&maskse
, maskexpr
);
2287 gfc_init_block (&block
);
2288 gfc_add_block_to_block (&block
, &loop
.pre
);
2289 gfc_add_block_to_block (&block
, &loop
.post
);
2290 tmp
= gfc_finish_block (&block
);
2292 /* For the else part of the scalar mask, just initialize
2293 the pos variable the same way as above. */
2295 gfc_init_block (&elseblock
);
2296 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
2297 elsetmp
= gfc_finish_block (&elseblock
);
2299 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2300 gfc_add_expr_to_block (&block
, tmp
);
2301 gfc_add_block_to_block (&se
->pre
, &block
);
2305 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2306 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2308 gfc_cleanup_loop (&loop
);
2310 se
->expr
= convert (type
, pos
);
2314 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2323 gfc_actual_arglist
*actual
;
2328 gfc_expr
*arrayexpr
;
2334 gfc_conv_intrinsic_funcall (se
, expr
);
2338 type
= gfc_typenode_for_spec (&expr
->ts
);
2339 /* Initialize the result. */
2340 limit
= gfc_create_var (type
, "limit");
2341 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2342 switch (expr
->ts
.type
)
2345 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
, 0);
2349 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2356 /* We start with the most negative possible value for MAXVAL, and the most
2357 positive possible value for MINVAL. The most negative possible value is
2358 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2359 possible value is HUGE in both cases. */
2361 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2363 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2364 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
),
2365 tmp
, build_int_cst (type
, 1));
2367 gfc_add_modify (&se
->pre
, limit
, tmp
);
2369 /* Walk the arguments. */
2370 actual
= expr
->value
.function
.actual
;
2371 arrayexpr
= actual
->expr
;
2372 arrayss
= gfc_walk_expr (arrayexpr
);
2373 gcc_assert (arrayss
!= gfc_ss_terminator
);
2375 actual
= actual
->next
->next
;
2376 gcc_assert (actual
);
2377 maskexpr
= actual
->expr
;
2378 if (maskexpr
&& maskexpr
->rank
!= 0)
2380 maskss
= gfc_walk_expr (maskexpr
);
2381 gcc_assert (maskss
!= gfc_ss_terminator
);
2386 /* Initialize the scalarizer. */
2387 gfc_init_loopinfo (&loop
);
2388 gfc_add_ss_to_loop (&loop
, arrayss
);
2390 gfc_add_ss_to_loop (&loop
, maskss
);
2392 /* Initialize the loop. */
2393 gfc_conv_ss_startstride (&loop
);
2394 gfc_conv_loop_setup (&loop
, &expr
->where
);
2396 gfc_mark_ss_chain_used (arrayss
, 1);
2398 gfc_mark_ss_chain_used (maskss
, 1);
2399 /* Generate the loop body. */
2400 gfc_start_scalarized_body (&loop
, &body
);
2402 /* If we have a mask, only add this element if the mask is set. */
2405 gfc_init_se (&maskse
, NULL
);
2406 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2408 gfc_conv_expr_val (&maskse
, maskexpr
);
2409 gfc_add_block_to_block (&body
, &maskse
.pre
);
2411 gfc_start_block (&block
);
2414 gfc_init_block (&block
);
2416 /* Compare with the current limit. */
2417 gfc_init_se (&arrayse
, NULL
);
2418 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2419 arrayse
.ss
= arrayss
;
2420 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2421 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2423 /* Assign the value to the limit... */
2424 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2426 /* If it is a more extreme value. */
2427 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2428 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2429 gfc_add_expr_to_block (&block
, tmp
);
2430 gfc_add_block_to_block (&block
, &arrayse
.post
);
2432 tmp
= gfc_finish_block (&block
);
2434 /* We enclose the above in if (mask) {...}. */
2435 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2436 gfc_add_expr_to_block (&body
, tmp
);
2438 gfc_trans_scalarizing_loops (&loop
, &body
);
2440 /* For a scalar mask, enclose the loop in an if statement. */
2441 if (maskexpr
&& maskss
== NULL
)
2443 gfc_init_se (&maskse
, NULL
);
2444 gfc_conv_expr_val (&maskse
, maskexpr
);
2445 gfc_init_block (&block
);
2446 gfc_add_block_to_block (&block
, &loop
.pre
);
2447 gfc_add_block_to_block (&block
, &loop
.post
);
2448 tmp
= gfc_finish_block (&block
);
2450 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2451 gfc_add_expr_to_block (&block
, tmp
);
2452 gfc_add_block_to_block (&se
->pre
, &block
);
2456 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2457 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2460 gfc_cleanup_loop (&loop
);
2465 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2467 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2473 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2474 type
= TREE_TYPE (args
[0]);
2476 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2477 tmp
= fold_build2 (BIT_AND_EXPR
, type
, args
[0], tmp
);
2478 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2479 build_int_cst (type
, 0));
2480 type
= gfc_typenode_for_spec (&expr
->ts
);
2481 se
->expr
= convert (type
, tmp
);
2484 /* Generate code to perform the specified operation. */
2486 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2490 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2491 se
->expr
= fold_build2 (op
, TREE_TYPE (args
[0]), args
[0], args
[1]);
2496 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2500 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2501 se
->expr
= fold_build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2504 /* Set or clear a single bit. */
2506 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2513 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2514 type
= TREE_TYPE (args
[0]);
2516 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2522 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2524 se
->expr
= fold_build2 (op
, type
, args
[0], tmp
);
2527 /* Extract a sequence of bits.
2528 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2530 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2537 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2538 type
= TREE_TYPE (args
[0]);
2540 mask
= build_int_cst (type
, -1);
2541 mask
= fold_build2 (LSHIFT_EXPR
, type
, mask
, args
[2]);
2542 mask
= fold_build1 (BIT_NOT_EXPR
, type
, mask
);
2544 tmp
= fold_build2 (RSHIFT_EXPR
, type
, args
[0], args
[1]);
2546 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2549 /* RSHIFT (I, SHIFT) = I >> SHIFT
2550 LSHIFT (I, SHIFT) = I << SHIFT */
2552 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
2556 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2558 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
2559 TREE_TYPE (args
[0]), args
[0], args
[1]);
2562 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2564 : ((shift >= 0) ? i << shift : i >> -shift)
2565 where all shifts are logical shifts. */
2567 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2579 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2580 type
= TREE_TYPE (args
[0]);
2581 utype
= unsigned_type_for (type
);
2583 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2585 /* Left shift if positive. */
2586 lshift
= fold_build2 (LSHIFT_EXPR
, type
, args
[0], width
);
2588 /* Right shift if negative.
2589 We convert to an unsigned type because we want a logical shift.
2590 The standard doesn't define the case of shifting negative
2591 numbers, and we try to be compatible with other compilers, most
2592 notably g77, here. */
2593 rshift
= fold_convert (type
, fold_build2 (RSHIFT_EXPR
, utype
,
2594 convert (utype
, args
[0]), width
));
2596 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, args
[1],
2597 build_int_cst (TREE_TYPE (args
[1]), 0));
2598 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2600 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2601 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2603 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
2604 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2606 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2607 build_int_cst (type
, 0), tmp
);
2611 /* Circular shift. AKA rotate or barrel shift. */
2614 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2622 unsigned int num_args
;
2624 num_args
= gfc_intrinsic_argument_list_length (expr
);
2625 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
2627 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2631 /* Use a library function for the 3 parameter version. */
2632 tree int4type
= gfc_get_int_type (4);
2634 type
= TREE_TYPE (args
[0]);
2635 /* We convert the first argument to at least 4 bytes, and
2636 convert back afterwards. This removes the need for library
2637 functions for all argument sizes, and function will be
2638 aligned to at least 32 bits, so there's no loss. */
2639 if (expr
->ts
.kind
< 4)
2640 args
[0] = convert (int4type
, args
[0]);
2642 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2643 need loads of library functions. They cannot have values >
2644 BIT_SIZE (I) so the conversion is safe. */
2645 args
[1] = convert (int4type
, args
[1]);
2646 args
[2] = convert (int4type
, args
[2]);
2648 switch (expr
->ts
.kind
)
2653 tmp
= gfor_fndecl_math_ishftc4
;
2656 tmp
= gfor_fndecl_math_ishftc8
;
2659 tmp
= gfor_fndecl_math_ishftc16
;
2664 se
->expr
= build_call_expr (tmp
, 3, args
[0], args
[1], args
[2]);
2665 /* Convert the result back to the original type, if we extended
2666 the first argument's width above. */
2667 if (expr
->ts
.kind
< 4)
2668 se
->expr
= convert (type
, se
->expr
);
2672 type
= TREE_TYPE (args
[0]);
2674 /* Rotate left if positive. */
2675 lrot
= fold_build2 (LROTATE_EXPR
, type
, args
[0], args
[1]);
2677 /* Rotate right if negative. */
2678 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2679 rrot
= fold_build2 (RROTATE_EXPR
, type
, args
[0], tmp
);
2681 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
2682 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, args
[1], zero
);
2683 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2685 /* Do nothing if shift == 0. */
2686 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
2687 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, args
[0], rrot
);
2690 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
2691 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
2693 The conditional expression is necessary because the result of LEADZ(0)
2694 is defined, but the result of __builtin_clz(0) is undefined for most
2697 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
2698 difference in bit size between the argument of LEADZ and the C int. */
2701 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
2713 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2715 /* Which variant of __builtin_clz* should we call? */
2716 arg_kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
2717 i
= gfc_validate_kind (BT_INTEGER
, arg_kind
, false);
2723 arg_type
= unsigned_type_node
;
2728 arg_type
= long_unsigned_type_node
;
2733 arg_type
= long_long_unsigned_type_node
;
2741 /* Convert the actual argument to the proper argument type for the built-in
2742 function. But the return type is of the default INTEGER kind. */
2743 arg
= fold_convert (arg_type
, arg
);
2744 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
2746 /* Compute LEADZ for the case i .ne. 0. */
2747 s
= TYPE_PRECISION (arg_type
) - gfc_integer_kinds
[i
].bit_size
;
2748 tmp
= fold_convert (result_type
, build_call_expr (built_in_decls
[n
], 1, arg
));
2749 leadz
= fold_build2 (MINUS_EXPR
, result_type
,
2750 tmp
, build_int_cst (result_type
, s
));
2752 /* Build BIT_SIZE. */
2753 bit_size
= build_int_cst (result_type
, gfc_integer_kinds
[i
].bit_size
);
2755 /* ??? For some combinations of targets and integer kinds, the condition
2756 can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used. Later. */
2757 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2758 arg
, build_int_cst (arg_type
, 0));
2759 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, leadz
);
2762 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
2764 The conditional expression is necessary because the result of TRAILZ(0)
2765 is defined, but the result of __builtin_ctz(0) is undefined for most
2769 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
2780 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2782 /* Which variant of __builtin_clz* should we call? */
2783 arg_kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
2784 i
= gfc_validate_kind (BT_INTEGER
, arg_kind
, false);
2785 switch (expr
->ts
.kind
)
2790 arg_type
= unsigned_type_node
;
2795 arg_type
= long_unsigned_type_node
;
2800 arg_type
= long_long_unsigned_type_node
;
2808 /* Convert the actual argument to the proper argument type for the built-in
2809 function. But the return type is of the default INTEGER kind. */
2810 arg
= fold_convert (arg_type
, arg
);
2811 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
2813 /* Compute TRAILZ for the case i .ne. 0. */
2814 trailz
= fold_convert (result_type
, build_call_expr (built_in_decls
[n
], 1, arg
));
2816 /* Build BIT_SIZE. */
2817 bit_size
= build_int_cst (result_type
, gfc_integer_kinds
[i
].bit_size
);
2819 /* ??? For some combinations of targets and integer kinds, the condition
2820 can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used. Later. */
2821 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2822 arg
, build_int_cst (arg_type
, 0));
2823 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, trailz
);
2826 /* Process an intrinsic with unspecified argument-types that has an optional
2827 argument (which could be of type character), e.g. EOSHIFT. For those, we
2828 need to append the string length of the optional argument if it is not
2829 present and the type is really character.
2830 primary specifies the position (starting at 1) of the non-optional argument
2831 specifying the type and optional gives the position of the optional
2832 argument in the arglist. */
2835 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
2836 unsigned primary
, unsigned optional
)
2838 gfc_actual_arglist
* prim_arg
;
2839 gfc_actual_arglist
* opt_arg
;
2841 gfc_actual_arglist
* arg
;
2845 /* Find the two arguments given as position. */
2849 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2853 if (cur_pos
== primary
)
2855 if (cur_pos
== optional
)
2858 if (cur_pos
>= primary
&& cur_pos
>= optional
)
2861 gcc_assert (prim_arg
);
2862 gcc_assert (prim_arg
->expr
);
2863 gcc_assert (opt_arg
);
2865 /* If we do have type CHARACTER and the optional argument is really absent,
2866 append a dummy 0 as string length. */
2867 append_args
= NULL_TREE
;
2868 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
2872 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
2873 append_args
= gfc_chainon_list (append_args
, dummy
);
2876 /* Build the call itself. */
2877 sym
= gfc_get_symbol_for_expr (expr
);
2878 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
2883 /* The length of a character string. */
2885 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2895 gcc_assert (!se
->ss
);
2897 arg
= expr
->value
.function
.actual
->expr
;
2899 type
= gfc_typenode_for_spec (&expr
->ts
);
2900 switch (arg
->expr_type
)
2903 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2907 /* Obtain the string length from the function used by
2908 trans-array.c(gfc_trans_array_constructor). */
2910 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
2914 if (arg
->ref
== NULL
2915 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
2917 /* This doesn't catch all cases.
2918 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2919 and the surrounding thread. */
2920 sym
= arg
->symtree
->n
.sym
;
2921 decl
= gfc_get_symbol_decl (sym
);
2922 if (decl
== current_function_decl
&& sym
->attr
.function
2923 && (sym
->result
== sym
))
2924 decl
= gfc_get_fake_result_decl (sym
, 0);
2926 len
= sym
->ts
.cl
->backend_decl
;
2931 /* Otherwise fall through. */
2934 /* Anybody stupid enough to do this deserves inefficient code. */
2935 ss
= gfc_walk_expr (arg
);
2936 gfc_init_se (&argse
, se
);
2937 if (ss
== gfc_ss_terminator
)
2938 gfc_conv_expr (&argse
, arg
);
2940 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2941 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2942 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2943 len
= argse
.string_length
;
2946 se
->expr
= convert (type
, len
);
2949 /* The length of a character string not including trailing blanks. */
2951 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2953 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
2954 tree args
[2], type
, fndecl
;
2956 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2957 type
= gfc_typenode_for_spec (&expr
->ts
);
2960 fndecl
= gfor_fndecl_string_len_trim
;
2962 fndecl
= gfor_fndecl_string_len_trim_char4
;
2966 se
->expr
= build_call_expr (fndecl
, 2, args
[0], args
[1]);
2967 se
->expr
= convert (type
, se
->expr
);
2971 /* Returns the starting position of a substring within a string. */
2974 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
2977 tree logical4_type_node
= gfc_get_logical_type (4);
2981 unsigned int num_args
;
2983 args
= (tree
*) alloca (sizeof (tree
) * 5);
2985 /* Get number of arguments; characters count double due to the
2986 string length argument. Kind= is not passed to the library
2987 and thus ignored. */
2988 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
2993 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2994 type
= gfc_typenode_for_spec (&expr
->ts
);
2997 args
[4] = build_int_cst (logical4_type_node
, 0);
2999 args
[4] = convert (logical4_type_node
, args
[4]);
3001 fndecl
= build_addr (function
, current_function_decl
);
3002 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3004 se
->expr
= convert (type
, se
->expr
);
3008 /* The ascii value for a single character. */
3010 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
3012 tree args
[2], type
, pchartype
;
3014 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3015 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
3016 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
3017 args
[1] = fold_build1 (NOP_EXPR
, pchartype
, args
[1]);
3018 type
= gfc_typenode_for_spec (&expr
->ts
);
3020 se
->expr
= build_fold_indirect_ref (args
[1]);
3021 se
->expr
= convert (type
, se
->expr
);
3025 /* Intrinsic ISNAN calls __builtin_isnan. */
3028 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
3032 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3033 se
->expr
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
3034 STRIP_TYPE_NOPS (se
->expr
);
3035 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3039 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3040 their argument against a constant integer value. */
3043 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
3047 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3048 se
->expr
= fold_build2 (EQ_EXPR
, gfc_typenode_for_spec (&expr
->ts
),
3049 arg
, build_int_cst (TREE_TYPE (arg
), value
));
3054 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3057 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
3065 unsigned int num_args
;
3067 num_args
= gfc_intrinsic_argument_list_length (expr
);
3068 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
3070 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3071 if (expr
->ts
.type
!= BT_CHARACTER
)
3079 /* We do the same as in the non-character case, but the argument
3080 list is different because of the string length arguments. We
3081 also have to set the string length for the result. */
3088 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
3090 se
->string_length
= len
;
3092 type
= TREE_TYPE (tsource
);
3093 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
,
3094 fold_convert (type
, fsource
));
3098 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3100 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
3102 tree arg
, type
, tmp
;
3105 switch (expr
->ts
.kind
)
3108 frexp
= BUILT_IN_FREXPF
;
3111 frexp
= BUILT_IN_FREXP
;
3115 frexp
= BUILT_IN_FREXPL
;
3121 type
= gfc_typenode_for_spec (&expr
->ts
);
3122 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3123 tmp
= gfc_create_var (integer_type_node
, NULL
);
3124 se
->expr
= build_call_expr (built_in_decls
[frexp
], 2,
3125 fold_convert (type
, arg
),
3126 gfc_build_addr_expr (NULL_TREE
, tmp
));
3127 se
->expr
= fold_convert (type
, se
->expr
);
3131 /* NEAREST (s, dir) is translated into
3132 tmp = copysign (HUGE_VAL, dir);
3133 return nextafter (s, tmp);
3136 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
3138 tree args
[2], type
, tmp
;
3139 int nextafter
, copysign
, huge_val
;
3141 switch (expr
->ts
.kind
)
3144 nextafter
= BUILT_IN_NEXTAFTERF
;
3145 copysign
= BUILT_IN_COPYSIGNF
;
3146 huge_val
= BUILT_IN_HUGE_VALF
;
3149 nextafter
= BUILT_IN_NEXTAFTER
;
3150 copysign
= BUILT_IN_COPYSIGN
;
3151 huge_val
= BUILT_IN_HUGE_VAL
;
3155 nextafter
= BUILT_IN_NEXTAFTERL
;
3156 copysign
= BUILT_IN_COPYSIGNL
;
3157 huge_val
= BUILT_IN_HUGE_VALL
;
3163 type
= gfc_typenode_for_spec (&expr
->ts
);
3164 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3165 tmp
= build_call_expr (built_in_decls
[copysign
], 2,
3166 build_call_expr (built_in_decls
[huge_val
], 0),
3167 fold_convert (type
, args
[1]));
3168 se
->expr
= build_call_expr (built_in_decls
[nextafter
], 2,
3169 fold_convert (type
, args
[0]), tmp
);
3170 se
->expr
= fold_convert (type
, se
->expr
);
3174 /* SPACING (s) is translated into
3182 e = MAX_EXPR (e, emin);
3183 res = scalbn (1., e);
3187 where prec is the precision of s, gfc_real_kinds[k].digits,
3188 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3189 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3192 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
3194 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
3196 int frexp
, scalbn
, k
;
3199 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3200 prec
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].digits
);
3201 emin
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].min_exponent
- 1);
3202 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
3204 switch (expr
->ts
.kind
)
3207 frexp
= BUILT_IN_FREXPF
;
3208 scalbn
= BUILT_IN_SCALBNF
;
3211 frexp
= BUILT_IN_FREXP
;
3212 scalbn
= BUILT_IN_SCALBN
;
3216 frexp
= BUILT_IN_FREXPL
;
3217 scalbn
= BUILT_IN_SCALBNL
;
3223 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3224 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3226 type
= gfc_typenode_for_spec (&expr
->ts
);
3227 e
= gfc_create_var (integer_type_node
, NULL
);
3228 res
= gfc_create_var (type
, NULL
);
3231 /* Build the block for s /= 0. */
3232 gfc_start_block (&block
);
3233 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
3234 gfc_build_addr_expr (NULL_TREE
, e
));
3235 gfc_add_expr_to_block (&block
, tmp
);
3237 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, e
, prec
);
3238 gfc_add_modify (&block
, e
, fold_build2 (MAX_EXPR
, integer_type_node
,
3241 tmp
= build_call_expr (built_in_decls
[scalbn
], 2,
3242 build_real_from_int_cst (type
, integer_one_node
), e
);
3243 gfc_add_modify (&block
, res
, tmp
);
3245 /* Finish by building the IF statement. */
3246 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg
,
3247 build_real_from_int_cst (type
, integer_zero_node
));
3248 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
3249 gfc_finish_block (&block
));
3251 gfc_add_expr_to_block (&se
->pre
, tmp
);
3256 /* RRSPACING (s) is translated into
3263 x = scalbn (x, precision - e);
3267 where precision is gfc_real_kinds[k].digits. */
3270 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
3272 tree arg
, type
, e
, x
, cond
, stmt
, tmp
;
3273 int frexp
, scalbn
, fabs
, prec
, k
;
3276 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3277 prec
= gfc_real_kinds
[k
].digits
;
3278 switch (expr
->ts
.kind
)
3281 frexp
= BUILT_IN_FREXPF
;
3282 scalbn
= BUILT_IN_SCALBNF
;
3283 fabs
= BUILT_IN_FABSF
;
3286 frexp
= BUILT_IN_FREXP
;
3287 scalbn
= BUILT_IN_SCALBN
;
3288 fabs
= BUILT_IN_FABS
;
3292 frexp
= BUILT_IN_FREXPL
;
3293 scalbn
= BUILT_IN_SCALBNL
;
3294 fabs
= BUILT_IN_FABSL
;
3300 type
= gfc_typenode_for_spec (&expr
->ts
);
3301 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3302 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3304 e
= gfc_create_var (integer_type_node
, NULL
);
3305 x
= gfc_create_var (type
, NULL
);
3306 gfc_add_modify (&se
->pre
, x
,
3307 build_call_expr (built_in_decls
[fabs
], 1, arg
));
3310 gfc_start_block (&block
);
3311 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
3312 gfc_build_addr_expr (NULL_TREE
, e
));
3313 gfc_add_expr_to_block (&block
, tmp
);
3315 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
,
3316 build_int_cst (NULL_TREE
, prec
), e
);
3317 tmp
= build_call_expr (built_in_decls
[scalbn
], 2, x
, tmp
);
3318 gfc_add_modify (&block
, x
, tmp
);
3319 stmt
= gfc_finish_block (&block
);
3321 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, x
,
3322 build_real_from_int_cst (type
, integer_zero_node
));
3323 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt ());
3324 gfc_add_expr_to_block (&se
->pre
, tmp
);
3326 se
->expr
= fold_convert (type
, x
);
3330 /* SCALE (s, i) is translated into scalbn (s, i). */
3332 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
3337 switch (expr
->ts
.kind
)
3340 scalbn
= BUILT_IN_SCALBNF
;
3343 scalbn
= BUILT_IN_SCALBN
;
3347 scalbn
= BUILT_IN_SCALBNL
;
3353 type
= gfc_typenode_for_spec (&expr
->ts
);
3354 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3355 se
->expr
= build_call_expr (built_in_decls
[scalbn
], 2,
3356 fold_convert (type
, args
[0]),
3357 fold_convert (integer_type_node
, args
[1]));
3358 se
->expr
= fold_convert (type
, se
->expr
);
3362 /* SET_EXPONENT (s, i) is translated into
3363 scalbn (frexp (s, &dummy_int), i). */
3365 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
3367 tree args
[2], type
, tmp
;
3370 switch (expr
->ts
.kind
)
3373 frexp
= BUILT_IN_FREXPF
;
3374 scalbn
= BUILT_IN_SCALBNF
;
3377 frexp
= BUILT_IN_FREXP
;
3378 scalbn
= BUILT_IN_SCALBN
;
3382 frexp
= BUILT_IN_FREXPL
;
3383 scalbn
= BUILT_IN_SCALBNL
;
3389 type
= gfc_typenode_for_spec (&expr
->ts
);
3390 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3392 tmp
= gfc_create_var (integer_type_node
, NULL
);
3393 tmp
= build_call_expr (built_in_decls
[frexp
], 2,
3394 fold_convert (type
, args
[0]),
3395 gfc_build_addr_expr (NULL_TREE
, tmp
));
3396 se
->expr
= build_call_expr (built_in_decls
[scalbn
], 2, tmp
,
3397 fold_convert (integer_type_node
, args
[1]));
3398 se
->expr
= fold_convert (type
, se
->expr
);
3403 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
3405 gfc_actual_arglist
*actual
;
3413 gfc_init_se (&argse
, NULL
);
3414 actual
= expr
->value
.function
.actual
;
3416 ss
= gfc_walk_expr (actual
->expr
);
3417 gcc_assert (ss
!= gfc_ss_terminator
);
3418 argse
.want_pointer
= 1;
3419 argse
.data_not_needed
= 1;
3420 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
3421 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3422 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3423 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
3425 /* Build the call to size0. */
3426 fncall0
= build_call_expr (gfor_fndecl_size0
, 1, arg1
);
3428 actual
= actual
->next
;
3432 gfc_init_se (&argse
, NULL
);
3433 gfc_conv_expr_type (&argse
, actual
->expr
,
3434 gfc_array_index_type
);
3435 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3437 /* Unusually, for an intrinsic, size does not exclude
3438 an optional arg2, so we must test for it. */
3439 if (actual
->expr
->expr_type
== EXPR_VARIABLE
3440 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
3441 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
3444 /* Build the call to size1. */
3445 fncall1
= build_call_expr (gfor_fndecl_size1
, 2,
3448 gfc_init_se (&argse
, NULL
);
3449 argse
.want_pointer
= 1;
3450 argse
.data_not_needed
= 1;
3451 gfc_conv_expr (&argse
, actual
->expr
);
3452 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3453 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3454 argse
.expr
, null_pointer_node
);
3455 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3456 se
->expr
= fold_build3 (COND_EXPR
, pvoid_type_node
,
3457 tmp
, fncall1
, fncall0
);
3461 se
->expr
= NULL_TREE
;
3462 argse
.expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3463 argse
.expr
, gfc_index_one_node
);
3466 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
3468 argse
.expr
= gfc_index_zero_node
;
3469 se
->expr
= NULL_TREE
;
3474 if (se
->expr
== NULL_TREE
)
3476 tree ubound
, lbound
;
3478 arg1
= build_fold_indirect_ref (arg1
);
3479 ubound
= gfc_conv_descriptor_ubound (arg1
, argse
.expr
);
3480 lbound
= gfc_conv_descriptor_lbound (arg1
, argse
.expr
);
3481 se
->expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3483 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
->expr
,
3484 gfc_index_one_node
);
3485 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
3486 gfc_index_zero_node
);
3489 type
= gfc_typenode_for_spec (&expr
->ts
);
3490 se
->expr
= convert (type
, se
->expr
);
3494 /* Helper function to compute the size of a character variable,
3495 excluding the terminating null characters. The result has
3496 gfc_array_index_type type. */
3499 size_of_string_in_bytes (int kind
, tree string_length
)
3502 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
3504 bytesize
= build_int_cst (gfc_array_index_type
,
3505 gfc_character_kinds
[i
].bit_size
/ 8);
3507 return fold_build2 (MULT_EXPR
, gfc_array_index_type
, bytesize
,
3508 fold_convert (gfc_array_index_type
, string_length
));
3513 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
3526 arg
= expr
->value
.function
.actual
->expr
;
3528 gfc_init_se (&argse
, NULL
);
3529 ss
= gfc_walk_expr (arg
);
3531 if (ss
== gfc_ss_terminator
)
3533 gfc_conv_expr_reference (&argse
, arg
);
3534 source
= argse
.expr
;
3536 type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3538 /* Obtain the source word length. */
3539 if (arg
->ts
.type
== BT_CHARACTER
)
3540 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
3541 argse
.string_length
);
3543 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
3547 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
3548 argse
.want_pointer
= 0;
3549 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3550 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3551 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3553 /* Obtain the argument's word length. */
3554 if (arg
->ts
.type
== BT_CHARACTER
)
3555 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
3557 tmp
= fold_convert (gfc_array_index_type
,
3558 size_in_bytes (type
));
3559 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3561 /* Obtain the size of the array in bytes. */
3562 for (n
= 0; n
< arg
->rank
; n
++)
3565 idx
= gfc_rank_cst
[n
];
3566 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3567 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3568 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3570 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3571 tmp
, gfc_index_one_node
);
3572 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3574 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3576 se
->expr
= source_bytes
;
3579 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3583 /* Intrinsic string comparison functions. */
3586 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3590 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
3593 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
3594 expr
->value
.function
.actual
->expr
->ts
.kind
);
3595 se
->expr
= fold_build2 (op
, gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
3596 build_int_cst (TREE_TYPE (se
->expr
), 0));
3599 /* Generate a call to the adjustl/adjustr library function. */
3601 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
3609 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
3612 type
= TREE_TYPE (args
[2]);
3613 var
= gfc_conv_string_tmp (se
, type
, len
);
3616 tmp
= build_call_expr (fndecl
, 3, args
[0], args
[1], args
[2]);
3617 gfc_add_expr_to_block (&se
->pre
, tmp
);
3619 se
->string_length
= len
;
3623 /* Generate code for the TRANSFER intrinsic:
3625 DEST = TRANSFER (SOURCE, MOLD)
3627 typeof<DEST> = typeof<MOLD>
3632 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3634 typeof<DEST> = typeof<MOLD>
3636 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3637 sizeof (DEST(0) * SIZE). */
3639 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
3656 gfc_actual_arglist
*arg
;
3666 info
= &se
->ss
->data
.info
;
3668 /* Convert SOURCE. The output from this stage is:-
3669 source_bytes = length of the source in bytes
3670 source = pointer to the source data. */
3671 arg
= expr
->value
.function
.actual
;
3673 /* Ensure double transfer through LOGICAL preserves all
3675 if (arg
->expr
->expr_type
== EXPR_FUNCTION
3676 && arg
->expr
->value
.function
.esym
== NULL
3677 && arg
->expr
->value
.function
.isym
!= NULL
3678 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
3679 && arg
->expr
->ts
.type
== BT_LOGICAL
3680 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
3681 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
3683 gfc_init_se (&argse
, NULL
);
3684 ss
= gfc_walk_expr (arg
->expr
);
3686 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3688 /* Obtain the pointer to source and the length of source in bytes. */
3689 if (ss
== gfc_ss_terminator
)
3691 gfc_conv_expr_reference (&argse
, arg
->expr
);
3692 source
= argse
.expr
;
3694 source_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3696 /* Obtain the source word length. */
3697 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3698 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
3699 argse
.string_length
);
3701 tmp
= fold_convert (gfc_array_index_type
,
3702 size_in_bytes (source_type
));
3706 argse
.want_pointer
= 0;
3707 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3708 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3709 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3711 /* Repack the source if not a full variable array. */
3712 if (arg
->expr
->expr_type
== EXPR_VARIABLE
3713 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
3715 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
3717 if (gfc_option
.warn_array_temp
)
3718 gfc_warning ("Creating array temporary at %L", &expr
->where
);
3720 source
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
3721 source
= gfc_evaluate_now (source
, &argse
.pre
);
3723 /* Free the temporary. */
3724 gfc_start_block (&block
);
3725 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
3726 gfc_add_expr_to_block (&block
, tmp
);
3727 stmt
= gfc_finish_block (&block
);
3729 /* Clean up if it was repacked. */
3730 gfc_init_block (&block
);
3731 tmp
= gfc_conv_array_data (argse
.expr
);
3732 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
3733 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3734 gfc_add_expr_to_block (&block
, tmp
);
3735 gfc_add_block_to_block (&block
, &se
->post
);
3736 gfc_init_block (&se
->post
);
3737 gfc_add_block_to_block (&se
->post
, &block
);
3740 /* Obtain the source word length. */
3741 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3742 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
3743 argse
.string_length
);
3745 tmp
= fold_convert (gfc_array_index_type
,
3746 size_in_bytes (source_type
));
3748 /* Obtain the size of the array in bytes. */
3749 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
3750 for (n
= 0; n
< arg
->expr
->rank
; n
++)
3753 idx
= gfc_rank_cst
[n
];
3754 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3755 stride
= gfc_conv_descriptor_stride (argse
.expr
, idx
);
3756 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3757 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3758 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3760 gfc_add_modify (&argse
.pre
, extent
, tmp
);
3761 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3762 extent
, gfc_index_one_node
);
3763 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3768 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3769 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3770 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3772 /* Now convert MOLD. The outputs are:
3773 mold_type = the TREE type of MOLD
3774 dest_word_len = destination word length in bytes. */
3777 gfc_init_se (&argse
, NULL
);
3778 ss
= gfc_walk_expr (arg
->expr
);
3780 scalar_mold
= arg
->expr
->rank
== 0;
3782 if (ss
== gfc_ss_terminator
)
3784 gfc_conv_expr_reference (&argse
, arg
->expr
);
3785 mold_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3789 gfc_init_se (&argse
, NULL
);
3790 argse
.want_pointer
= 0;
3791 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3792 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3795 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3796 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3798 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
3800 /* If this TRANSFER is nested in another TRANSFER, use a type
3801 that preserves all bits. */
3802 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
3803 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
3806 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3808 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
3809 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
3812 tmp
= fold_convert (gfc_array_index_type
,
3813 size_in_bytes (mold_type
));
3815 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
3816 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
3818 /* Finally convert SIZE, if it is present. */
3820 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
3824 gfc_init_se (&argse
, NULL
);
3825 gfc_conv_expr_reference (&argse
, arg
->expr
);
3826 tmp
= convert (gfc_array_index_type
,
3827 build_fold_indirect_ref (argse
.expr
));
3828 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3829 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3834 /* Separate array and scalar results. */
3835 if (scalar_mold
&& tmp
== NULL_TREE
)
3836 goto scalar_transfer
;
3838 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3839 if (tmp
!= NULL_TREE
)
3840 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3841 tmp
, dest_word_len
);
3845 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
3846 gfc_add_modify (&se
->pre
, size_words
,
3847 fold_build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
3848 size_bytes
, dest_word_len
));
3850 /* Evaluate the bounds of the result. If the loop range exists, we have
3851 to check if it is too large. If so, we modify loop->to be consistent
3852 with min(size, size(source)). Otherwise, size is made consistent with
3853 the loop range, so that the right number of bytes is transferred.*/
3854 n
= se
->loop
->order
[0];
3855 if (se
->loop
->to
[n
] != NULL_TREE
)
3857 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3858 se
->loop
->to
[n
], se
->loop
->from
[n
]);
3859 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3860 tmp
, gfc_index_one_node
);
3861 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3863 gfc_add_modify (&se
->pre
, size_words
, tmp
);
3864 gfc_add_modify (&se
->pre
, size_bytes
,
3865 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3866 size_words
, dest_word_len
));
3867 upper
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3868 size_words
, se
->loop
->from
[n
]);
3869 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3870 upper
, gfc_index_one_node
);
3874 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3875 size_words
, gfc_index_one_node
);
3876 se
->loop
->from
[n
] = gfc_index_zero_node
;
3879 se
->loop
->to
[n
] = upper
;
3881 /* Build a destination descriptor, using the pointer, source, as the
3883 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
3884 info
, mold_type
, NULL_TREE
, false, true, false,
3887 /* Cast the pointer to the result. */
3888 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3889 tmp
= fold_convert (pvoid_type_node
, tmp
);
3891 /* Use memcpy to do the transfer. */
3892 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
],
3895 fold_convert (pvoid_type_node
, source
),
3896 fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3897 size_bytes
, source_bytes
));
3898 gfc_add_expr_to_block (&se
->pre
, tmp
);
3900 se
->expr
= info
->descriptor
;
3901 if (expr
->ts
.type
== BT_CHARACTER
)
3902 se
->string_length
= dest_word_len
;
3906 /* Deal with scalar results. */
3908 extent
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3909 dest_word_len
, source_bytes
);
3911 if (expr
->ts
.type
== BT_CHARACTER
)
3916 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
3917 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
3920 /* If source is longer than the destination, use a pointer to
3921 the source directly. */
3922 gfc_init_block (&block
);
3923 gfc_add_modify (&block
, tmpdecl
, ptr
);
3924 direct
= gfc_finish_block (&block
);
3926 /* Otherwise, allocate a string with the length of the destination
3927 and copy the source into it. */
3928 gfc_init_block (&block
);
3929 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
3930 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
3931 gfc_add_modify (&block
, tmpdecl
,
3932 fold_convert (TREE_TYPE (ptr
), tmp
));
3933 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
3934 fold_convert (pvoid_type_node
, tmpdecl
),
3935 fold_convert (pvoid_type_node
, ptr
),
3937 gfc_add_expr_to_block (&block
, tmp
);
3938 indirect
= gfc_finish_block (&block
);
3940 /* Wrap it up with the condition. */
3941 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
,
3942 dest_word_len
, source_bytes
);
3943 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
3944 gfc_add_expr_to_block (&se
->pre
, tmp
);
3947 se
->string_length
= dest_word_len
;
3951 tmpdecl
= gfc_create_var (mold_type
, "transfer");
3953 ptr
= convert (build_pointer_type (mold_type
), source
);
3955 /* Use memcpy to do the transfer. */
3956 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
3957 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
3958 fold_convert (pvoid_type_node
, tmp
),
3959 fold_convert (pvoid_type_node
, ptr
),
3961 gfc_add_expr_to_block (&se
->pre
, tmp
);
3968 /* Generate code for the ALLOCATED intrinsic.
3969 Generate inline code that directly check the address of the argument. */
3972 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
3974 gfc_actual_arglist
*arg1
;
3979 gfc_init_se (&arg1se
, NULL
);
3980 arg1
= expr
->value
.function
.actual
;
3981 ss1
= gfc_walk_expr (arg1
->expr
);
3982 arg1se
.descriptor_only
= 1;
3983 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3985 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3986 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3987 tmp
, fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
3988 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
3992 /* Generate code for the ASSOCIATED intrinsic.
3993 If both POINTER and TARGET are arrays, generate a call to library function
3994 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3995 In other cases, generate inline code that directly compare the address of
3996 POINTER with the address of TARGET. */
3999 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
4001 gfc_actual_arglist
*arg1
;
4002 gfc_actual_arglist
*arg2
;
4007 tree nonzero_charlen
;
4008 tree nonzero_arraylen
;
4011 gfc_init_se (&arg1se
, NULL
);
4012 gfc_init_se (&arg2se
, NULL
);
4013 arg1
= expr
->value
.function
.actual
;
4015 ss1
= gfc_walk_expr (arg1
->expr
);
4019 /* No optional target. */
4020 if (ss1
== gfc_ss_terminator
)
4022 /* A pointer to a scalar. */
4023 arg1se
.want_pointer
= 1;
4024 gfc_conv_expr (&arg1se
, arg1
->expr
);
4029 /* A pointer to an array. */
4030 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4031 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
4033 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
4034 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
4035 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp2
,
4036 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
4041 /* An optional target. */
4042 ss2
= gfc_walk_expr (arg2
->expr
);
4044 nonzero_charlen
= NULL_TREE
;
4045 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
4046 nonzero_charlen
= fold_build2 (NE_EXPR
, boolean_type_node
,
4047 arg1
->expr
->ts
.cl
->backend_decl
,
4050 if (ss1
== gfc_ss_terminator
)
4052 /* A pointer to a scalar. */
4053 gcc_assert (ss2
== gfc_ss_terminator
);
4054 arg1se
.want_pointer
= 1;
4055 gfc_conv_expr (&arg1se
, arg1
->expr
);
4056 arg2se
.want_pointer
= 1;
4057 gfc_conv_expr (&arg2se
, arg2
->expr
);
4058 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
4059 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
4060 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4061 arg1se
.expr
, arg2se
.expr
);
4062 tmp2
= fold_build2 (NE_EXPR
, boolean_type_node
,
4063 arg1se
.expr
, null_pointer_node
);
4064 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4069 /* An array pointer of zero length is not associated if target is
4071 arg1se
.descriptor_only
= 1;
4072 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
4073 tmp
= gfc_conv_descriptor_stride (arg1se
.expr
,
4074 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
4075 nonzero_arraylen
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
4076 build_int_cst (TREE_TYPE (tmp
), 0));
4078 /* A pointer to an array, call library function _gfor_associated. */
4079 gcc_assert (ss2
!= gfc_ss_terminator
);
4080 arg1se
.want_pointer
= 1;
4081 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4083 arg2se
.want_pointer
= 1;
4084 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
4085 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
4086 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
4087 se
->expr
= build_call_expr (gfor_fndecl_associated
, 2,
4088 arg1se
.expr
, arg2se
.expr
);
4089 se
->expr
= convert (boolean_type_node
, se
->expr
);
4090 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4091 se
->expr
, nonzero_arraylen
);
4094 /* If target is present zero character length pointers cannot
4096 if (nonzero_charlen
!= NULL_TREE
)
4097 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4098 se
->expr
, nonzero_charlen
);
4101 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4105 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4108 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
4112 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4113 se
->expr
= build_call_expr (gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
4114 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4118 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4121 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
4125 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4127 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4128 type
= gfc_get_int_type (4);
4129 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
4131 /* Convert it to the required type. */
4132 type
= gfc_typenode_for_spec (&expr
->ts
);
4133 se
->expr
= build_call_expr (gfor_fndecl_si_kind
, 1, arg
);
4134 se
->expr
= fold_convert (type
, se
->expr
);
4138 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4141 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
4143 gfc_actual_arglist
*actual
;
4148 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4150 gfc_init_se (&argse
, se
);
4152 /* Pass a NULL pointer for an absent arg. */
4153 if (actual
->expr
== NULL
)
4154 argse
.expr
= null_pointer_node
;
4160 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4162 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4163 ts
.type
= BT_INTEGER
;
4164 ts
.kind
= gfc_c_int_kind
;
4165 gfc_convert_type (actual
->expr
, &ts
, 2);
4167 gfc_conv_expr_reference (&argse
, actual
->expr
);
4170 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4171 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4172 args
= gfc_chainon_list (args
, argse
.expr
);
4175 /* Convert it to the required type. */
4176 type
= gfc_typenode_for_spec (&expr
->ts
);
4177 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
4178 se
->expr
= fold_convert (type
, se
->expr
);
4182 /* Generate code for TRIM (A) intrinsic function. */
4185 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
4195 unsigned int num_args
;
4197 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4198 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
4200 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4201 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
4202 len
= gfc_create_var (gfc_get_int_type (4), "len");
4204 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4205 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4208 if (expr
->ts
.kind
== 1)
4209 function
= gfor_fndecl_string_trim
;
4210 else if (expr
->ts
.kind
== 4)
4211 function
= gfor_fndecl_string_trim_char4
;
4215 fndecl
= build_addr (function
, current_function_decl
);
4216 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4218 gfc_add_expr_to_block (&se
->pre
, tmp
);
4220 /* Free the temporary afterwards, if necessary. */
4221 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4222 len
, build_int_cst (TREE_TYPE (len
), 0));
4223 tmp
= gfc_call_free (var
);
4224 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
4225 gfc_add_expr_to_block (&se
->post
, tmp
);
4228 se
->string_length
= len
;
4232 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
4235 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
4237 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
4238 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
4240 stmtblock_t block
, body
;
4243 /* We store in charsize the size of a character. */
4244 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
4245 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
4247 /* Get the arguments. */
4248 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4249 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
4251 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
4252 ncopies_type
= TREE_TYPE (ncopies
);
4254 /* Check that NCOPIES is not negative. */
4255 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
4256 build_int_cst (ncopies_type
, 0));
4257 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4258 "Argument NCOPIES of REPEAT intrinsic is negative "
4259 "(its value is %lld)",
4260 fold_convert (long_integer_type_node
, ncopies
));
4262 /* If the source length is zero, any non negative value of NCOPIES
4263 is valid, and nothing happens. */
4264 n
= gfc_create_var (ncopies_type
, "ncopies");
4265 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4266 build_int_cst (size_type_node
, 0));
4267 tmp
= fold_build3 (COND_EXPR
, ncopies_type
, cond
,
4268 build_int_cst (ncopies_type
, 0), ncopies
);
4269 gfc_add_modify (&se
->pre
, n
, tmp
);
4272 /* Check that ncopies is not too large: ncopies should be less than
4273 (or equal to) MAX / slen, where MAX is the maximal integer of
4274 the gfc_charlen_type_node type. If slen == 0, we need a special
4275 case to avoid the division by zero. */
4276 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4277 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
4278 max
= fold_build2 (TRUNC_DIV_EXPR
, size_type_node
,
4279 fold_convert (size_type_node
, max
), slen
);
4280 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
4281 ? size_type_node
: ncopies_type
;
4282 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4283 fold_convert (largest
, ncopies
),
4284 fold_convert (largest
, max
));
4285 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4286 build_int_cst (size_type_node
, 0));
4287 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
, boolean_false_node
,
4289 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4290 "Argument NCOPIES of REPEAT intrinsic is too large");
4292 /* Compute the destination length. */
4293 dlen
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4294 fold_convert (gfc_charlen_type_node
, slen
),
4295 fold_convert (gfc_charlen_type_node
, ncopies
));
4296 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
4297 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
4299 /* Generate the code to do the repeat operation:
4300 for (i = 0; i < ncopies; i++)
4301 memmove (dest + (i * slen * size), src, slen*size); */
4302 gfc_start_block (&block
);
4303 count
= gfc_create_var (ncopies_type
, "count");
4304 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
4305 exit_label
= gfc_build_label_decl (NULL_TREE
);
4307 /* Start the loop body. */
4308 gfc_start_block (&body
);
4310 /* Exit the loop if count >= ncopies. */
4311 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, count
, ncopies
);
4312 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4313 TREE_USED (exit_label
) = 1;
4314 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
4315 build_empty_stmt ());
4316 gfc_add_expr_to_block (&body
, tmp
);
4318 /* Call memmove (dest + (i*slen*size), src, slen*size). */
4319 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4320 fold_convert (gfc_charlen_type_node
, slen
),
4321 fold_convert (gfc_charlen_type_node
, count
));
4322 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4323 tmp
, fold_convert (gfc_charlen_type_node
, size
));
4324 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pvoid_type_node
,
4325 fold_convert (pvoid_type_node
, dest
),
4326 fold_convert (sizetype
, tmp
));
4327 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], 3, tmp
, src
,
4328 fold_build2 (MULT_EXPR
, size_type_node
, slen
,
4329 fold_convert (size_type_node
, size
)));
4330 gfc_add_expr_to_block (&body
, tmp
);
4332 /* Increment count. */
4333 tmp
= fold_build2 (PLUS_EXPR
, ncopies_type
,
4334 count
, build_int_cst (TREE_TYPE (count
), 1));
4335 gfc_add_modify (&body
, count
, tmp
);
4337 /* Build the loop. */
4338 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
4339 gfc_add_expr_to_block (&block
, tmp
);
4341 /* Add the exit label. */
4342 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4343 gfc_add_expr_to_block (&block
, tmp
);
4345 /* Finish the block. */
4346 tmp
= gfc_finish_block (&block
);
4347 gfc_add_expr_to_block (&se
->pre
, tmp
);
4349 /* Set the result value. */
4351 se
->string_length
= dlen
;
4355 /* Generate code for the IARGC intrinsic. */
4358 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
4364 /* Call the library function. This always returns an INTEGER(4). */
4365 fndecl
= gfor_fndecl_iargc
;
4366 tmp
= build_call_expr (fndecl
, 0);
4368 /* Convert it to the required type. */
4369 type
= gfc_typenode_for_spec (&expr
->ts
);
4370 tmp
= fold_convert (type
, tmp
);
4376 /* The loc intrinsic returns the address of its argument as
4377 gfc_index_integer_kind integer. */
4380 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
4386 gcc_assert (!se
->ss
);
4388 arg_expr
= expr
->value
.function
.actual
->expr
;
4389 ss
= gfc_walk_expr (arg_expr
);
4390 if (ss
== gfc_ss_terminator
)
4391 gfc_conv_expr_reference (se
, arg_expr
);
4393 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1, NULL
, NULL
);
4394 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
4396 /* Create a temporary variable for loc return value. Without this,
4397 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4398 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
4399 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
4400 se
->expr
= temp_var
;
4403 /* Generate code for an intrinsic function. Some map directly to library
4404 calls, others get special handling. In some cases the name of the function
4405 used depends on the type specifiers. */
4408 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
4410 gfc_intrinsic_sym
*isym
;
4415 isym
= expr
->value
.function
.isym
;
4417 name
= &expr
->value
.function
.name
[2];
4419 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
4421 lib
= gfc_is_intrinsic_libcall (expr
);
4425 se
->ignore_optional
= 1;
4427 switch (expr
->value
.function
.isym
->id
)
4429 case GFC_ISYM_EOSHIFT
:
4431 case GFC_ISYM_RESHAPE
:
4432 /* For all of those the first argument specifies the type and the
4433 third is optional. */
4434 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
4438 gfc_conv_intrinsic_funcall (se
, expr
);
4446 switch (expr
->value
.function
.isym
->id
)
4451 case GFC_ISYM_REPEAT
:
4452 gfc_conv_intrinsic_repeat (se
, expr
);
4456 gfc_conv_intrinsic_trim (se
, expr
);
4459 case GFC_ISYM_SC_KIND
:
4460 gfc_conv_intrinsic_sc_kind (se
, expr
);
4463 case GFC_ISYM_SI_KIND
:
4464 gfc_conv_intrinsic_si_kind (se
, expr
);
4467 case GFC_ISYM_SR_KIND
:
4468 gfc_conv_intrinsic_sr_kind (se
, expr
);
4471 case GFC_ISYM_EXPONENT
:
4472 gfc_conv_intrinsic_exponent (se
, expr
);
4476 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4478 fndecl
= gfor_fndecl_string_scan
;
4480 fndecl
= gfor_fndecl_string_scan_char4
;
4484 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4487 case GFC_ISYM_VERIFY
:
4488 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4490 fndecl
= gfor_fndecl_string_verify
;
4492 fndecl
= gfor_fndecl_string_verify_char4
;
4496 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4499 case GFC_ISYM_ALLOCATED
:
4500 gfc_conv_allocated (se
, expr
);
4503 case GFC_ISYM_ASSOCIATED
:
4504 gfc_conv_associated(se
, expr
);
4508 gfc_conv_intrinsic_abs (se
, expr
);
4511 case GFC_ISYM_ADJUSTL
:
4512 if (expr
->ts
.kind
== 1)
4513 fndecl
= gfor_fndecl_adjustl
;
4514 else if (expr
->ts
.kind
== 4)
4515 fndecl
= gfor_fndecl_adjustl_char4
;
4519 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
4522 case GFC_ISYM_ADJUSTR
:
4523 if (expr
->ts
.kind
== 1)
4524 fndecl
= gfor_fndecl_adjustr
;
4525 else if (expr
->ts
.kind
== 4)
4526 fndecl
= gfor_fndecl_adjustr_char4
;
4530 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
4533 case GFC_ISYM_AIMAG
:
4534 gfc_conv_intrinsic_imagpart (se
, expr
);
4538 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
4542 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
4545 case GFC_ISYM_ANINT
:
4546 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
4550 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
4554 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
4557 case GFC_ISYM_BTEST
:
4558 gfc_conv_intrinsic_btest (se
, expr
);
4561 case GFC_ISYM_ACHAR
:
4563 gfc_conv_intrinsic_char (se
, expr
);
4566 case GFC_ISYM_CONVERSION
:
4568 case GFC_ISYM_LOGICAL
:
4570 gfc_conv_intrinsic_conversion (se
, expr
);
4573 /* Integer conversions are handled separately to make sure we get the
4574 correct rounding mode. */
4579 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
4583 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
4586 case GFC_ISYM_CEILING
:
4587 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
4590 case GFC_ISYM_FLOOR
:
4591 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
4595 gfc_conv_intrinsic_mod (se
, expr
, 0);
4598 case GFC_ISYM_MODULO
:
4599 gfc_conv_intrinsic_mod (se
, expr
, 1);
4602 case GFC_ISYM_CMPLX
:
4603 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
4606 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
4607 gfc_conv_intrinsic_iargc (se
, expr
);
4610 case GFC_ISYM_COMPLEX
:
4611 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
4614 case GFC_ISYM_CONJG
:
4615 gfc_conv_intrinsic_conjg (se
, expr
);
4618 case GFC_ISYM_COUNT
:
4619 gfc_conv_intrinsic_count (se
, expr
);
4622 case GFC_ISYM_CTIME
:
4623 gfc_conv_intrinsic_ctime (se
, expr
);
4627 gfc_conv_intrinsic_dim (se
, expr
);
4630 case GFC_ISYM_DOT_PRODUCT
:
4631 gfc_conv_intrinsic_dot_product (se
, expr
);
4634 case GFC_ISYM_DPROD
:
4635 gfc_conv_intrinsic_dprod (se
, expr
);
4638 case GFC_ISYM_FDATE
:
4639 gfc_conv_intrinsic_fdate (se
, expr
);
4642 case GFC_ISYM_FRACTION
:
4643 gfc_conv_intrinsic_fraction (se
, expr
);
4647 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
4650 case GFC_ISYM_IBCLR
:
4651 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
4654 case GFC_ISYM_IBITS
:
4655 gfc_conv_intrinsic_ibits (se
, expr
);
4658 case GFC_ISYM_IBSET
:
4659 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
4662 case GFC_ISYM_IACHAR
:
4663 case GFC_ISYM_ICHAR
:
4664 /* We assume ASCII character sequence. */
4665 gfc_conv_intrinsic_ichar (se
, expr
);
4668 case GFC_ISYM_IARGC
:
4669 gfc_conv_intrinsic_iargc (se
, expr
);
4673 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4676 case GFC_ISYM_INDEX
:
4677 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4679 fndecl
= gfor_fndecl_string_index
;
4681 fndecl
= gfor_fndecl_string_index_char4
;
4685 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4689 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4692 case GFC_ISYM_IS_IOSTAT_END
:
4693 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
4696 case GFC_ISYM_IS_IOSTAT_EOR
:
4697 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
4700 case GFC_ISYM_ISNAN
:
4701 gfc_conv_intrinsic_isnan (se
, expr
);
4704 case GFC_ISYM_LSHIFT
:
4705 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
4708 case GFC_ISYM_RSHIFT
:
4709 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
4712 case GFC_ISYM_ISHFT
:
4713 gfc_conv_intrinsic_ishft (se
, expr
);
4716 case GFC_ISYM_ISHFTC
:
4717 gfc_conv_intrinsic_ishftc (se
, expr
);
4720 case GFC_ISYM_LEADZ
:
4721 gfc_conv_intrinsic_leadz (se
, expr
);
4724 case GFC_ISYM_TRAILZ
:
4725 gfc_conv_intrinsic_trailz (se
, expr
);
4728 case GFC_ISYM_LBOUND
:
4729 gfc_conv_intrinsic_bound (se
, expr
, 0);
4732 case GFC_ISYM_TRANSPOSE
:
4733 if (se
->ss
&& se
->ss
->useflags
)
4735 gfc_conv_tmp_array_ref (se
);
4736 gfc_advance_se_ss_chain (se
);
4739 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
4743 gfc_conv_intrinsic_len (se
, expr
);
4746 case GFC_ISYM_LEN_TRIM
:
4747 gfc_conv_intrinsic_len_trim (se
, expr
);
4751 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
4755 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
4759 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
4763 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
4767 if (expr
->ts
.type
== BT_CHARACTER
)
4768 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
4770 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
4773 case GFC_ISYM_MAXLOC
:
4774 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
4777 case GFC_ISYM_MAXVAL
:
4778 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
4781 case GFC_ISYM_MERGE
:
4782 gfc_conv_intrinsic_merge (se
, expr
);
4786 if (expr
->ts
.type
== BT_CHARACTER
)
4787 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
4789 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
4792 case GFC_ISYM_MINLOC
:
4793 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
4796 case GFC_ISYM_MINVAL
:
4797 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
4800 case GFC_ISYM_NEAREST
:
4801 gfc_conv_intrinsic_nearest (se
, expr
);
4805 gfc_conv_intrinsic_not (se
, expr
);
4809 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4812 case GFC_ISYM_PRESENT
:
4813 gfc_conv_intrinsic_present (se
, expr
);
4816 case GFC_ISYM_PRODUCT
:
4817 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
4820 case GFC_ISYM_RRSPACING
:
4821 gfc_conv_intrinsic_rrspacing (se
, expr
);
4824 case GFC_ISYM_SET_EXPONENT
:
4825 gfc_conv_intrinsic_set_exponent (se
, expr
);
4828 case GFC_ISYM_SCALE
:
4829 gfc_conv_intrinsic_scale (se
, expr
);
4833 gfc_conv_intrinsic_sign (se
, expr
);
4837 gfc_conv_intrinsic_size (se
, expr
);
4840 case GFC_ISYM_SIZEOF
:
4841 gfc_conv_intrinsic_sizeof (se
, expr
);
4844 case GFC_ISYM_SPACING
:
4845 gfc_conv_intrinsic_spacing (se
, expr
);
4849 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
4852 case GFC_ISYM_TRANSFER
:
4853 if (se
->ss
&& se
->ss
->useflags
)
4855 /* Access the previously obtained result. */
4856 gfc_conv_tmp_array_ref (se
);
4857 gfc_advance_se_ss_chain (se
);
4860 gfc_conv_intrinsic_transfer (se
, expr
);
4863 case GFC_ISYM_TTYNAM
:
4864 gfc_conv_intrinsic_ttynam (se
, expr
);
4867 case GFC_ISYM_UBOUND
:
4868 gfc_conv_intrinsic_bound (se
, expr
, 1);
4872 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4876 gfc_conv_intrinsic_loc (se
, expr
);
4879 case GFC_ISYM_ACCESS
:
4880 case GFC_ISYM_CHDIR
:
4881 case GFC_ISYM_CHMOD
:
4882 case GFC_ISYM_DTIME
:
4883 case GFC_ISYM_ETIME
:
4885 case GFC_ISYM_FGETC
:
4888 case GFC_ISYM_FPUTC
:
4889 case GFC_ISYM_FSTAT
:
4890 case GFC_ISYM_FTELL
:
4891 case GFC_ISYM_GETCWD
:
4892 case GFC_ISYM_GETGID
:
4893 case GFC_ISYM_GETPID
:
4894 case GFC_ISYM_GETUID
:
4895 case GFC_ISYM_HOSTNM
:
4897 case GFC_ISYM_IERRNO
:
4898 case GFC_ISYM_IRAND
:
4899 case GFC_ISYM_ISATTY
:
4901 case GFC_ISYM_LSTAT
:
4902 case GFC_ISYM_MALLOC
:
4903 case GFC_ISYM_MATMUL
:
4904 case GFC_ISYM_MCLOCK
:
4905 case GFC_ISYM_MCLOCK8
:
4907 case GFC_ISYM_RENAME
:
4908 case GFC_ISYM_SECOND
:
4909 case GFC_ISYM_SECNDS
:
4910 case GFC_ISYM_SIGNAL
:
4912 case GFC_ISYM_SYMLNK
:
4913 case GFC_ISYM_SYSTEM
:
4915 case GFC_ISYM_TIME8
:
4916 case GFC_ISYM_UMASK
:
4917 case GFC_ISYM_UNLINK
:
4918 gfc_conv_intrinsic_funcall (se
, expr
);
4921 case GFC_ISYM_EOSHIFT
:
4923 case GFC_ISYM_RESHAPE
:
4924 /* For those, expr->rank should always be >0 and thus the if above the
4925 switch should have matched. */
4930 gfc_conv_intrinsic_lib_function (se
, expr
);
4936 /* This generates code to execute before entering the scalarization loop.
4937 Currently does nothing. */
4940 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
4942 switch (ss
->expr
->value
.function
.isym
->id
)
4944 case GFC_ISYM_UBOUND
:
4945 case GFC_ISYM_LBOUND
:
4954 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4955 inside the scalarization loop. */
4958 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
4962 /* The two argument version returns a scalar. */
4963 if (expr
->value
.function
.actual
->next
->expr
)
4966 newss
= gfc_get_ss ();
4967 newss
->type
= GFC_SS_INTRINSIC
;
4970 newss
->data
.info
.dimen
= 1;
4976 /* Walk an intrinsic array libcall. */
4979 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
4983 gcc_assert (expr
->rank
> 0);
4985 newss
= gfc_get_ss ();
4986 newss
->type
= GFC_SS_FUNCTION
;
4989 newss
->data
.info
.dimen
= expr
->rank
;
4995 /* Returns nonzero if the specified intrinsic function call maps directly to
4996 an external library call. Should only be used for functions that return
5000 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
5002 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
5003 gcc_assert (expr
->rank
> 0);
5005 switch (expr
->value
.function
.isym
->id
)
5009 case GFC_ISYM_COUNT
:
5010 case GFC_ISYM_MATMUL
:
5011 case GFC_ISYM_MAXLOC
:
5012 case GFC_ISYM_MAXVAL
:
5013 case GFC_ISYM_MINLOC
:
5014 case GFC_ISYM_MINVAL
:
5015 case GFC_ISYM_PRODUCT
:
5017 case GFC_ISYM_SHAPE
:
5018 case GFC_ISYM_SPREAD
:
5019 case GFC_ISYM_TRANSPOSE
:
5020 /* Ignore absent optional parameters. */
5023 case GFC_ISYM_RESHAPE
:
5024 case GFC_ISYM_CSHIFT
:
5025 case GFC_ISYM_EOSHIFT
:
5027 case GFC_ISYM_UNPACK
:
5028 /* Pass absent optional parameters. */
5036 /* Walk an intrinsic function. */
5038 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
5039 gfc_intrinsic_sym
* isym
)
5043 if (isym
->elemental
)
5044 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
5046 if (expr
->rank
== 0)
5049 if (gfc_is_intrinsic_libcall (expr
))
5050 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5052 /* Special cases. */
5055 case GFC_ISYM_LBOUND
:
5056 case GFC_ISYM_UBOUND
:
5057 return gfc_walk_intrinsic_bound (ss
, expr
);
5059 case GFC_ISYM_TRANSFER
:
5060 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5063 /* This probably meant someone forgot to add an intrinsic to the above
5064 list(s) when they implemented it, or something's gone horribly
5070 #include "gt-fortran-trans-intrinsic.h"