1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
32 #include "tree-gimple.h"
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct gfc_intrinsic_map_t
GTY(())
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
51 enum gfc_generic_isym_id id
;
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 LIBM_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 true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
112 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
113 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
116 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
118 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
120 /* Functions built into gcc itself. */
121 #include "mathbuiltins.def"
123 /* Functions in libm. */
124 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
125 pattern for other mathbuiltins.def entries. At present we have no
126 optimizations for this in the common sources. */
127 LIBM_FUNCTION (SCALE
, "scalbn", false),
129 /* Functions in libgfortran. */
130 LIBF_FUNCTION (FRACTION
, "fraction", false),
131 LIBF_FUNCTION (NEAREST
, "nearest", false),
132 LIBF_FUNCTION (SET_EXPONENT
, "set_exponent", false),
135 LIBF_FUNCTION (NONE
, NULL
, false)
137 #undef DEFINE_MATH_BUILTIN
138 #undef DEFINE_MATH_BUILTIN_C
142 /* Structure for storing components of a floating number to be used by
143 elemental functions to manipulate reals. */
146 tree arg
; /* Variable tree to view convert to integer. */
147 tree expn
; /* Variable tree to save exponent. */
148 tree frac
; /* Variable tree to save fraction. */
149 tree smask
; /* Constant tree of sign's mask. */
150 tree emask
; /* Constant tree of exponent's mask. */
151 tree fmask
; /* Constant tree of fraction's mask. */
152 tree edigits
; /* Constant tree of the number of exponent bits. */
153 tree fdigits
; /* Constant tree of the number of fraction bits. */
154 tree f1
; /* Constant tree of the f1 defined in the real model. */
155 tree bias
; /* Constant tree of the bias of exponent in the memory. */
156 tree type
; /* Type tree of arg1. */
157 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
162 /* Evaluate the arguments to an intrinsic function. */
165 gfc_conv_intrinsic_function_args (gfc_se
* se
, gfc_expr
* expr
)
167 gfc_actual_arglist
*actual
;
172 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
174 /* Skip omitted optional arguments. */
178 /* Evaluate the parameter. This will substitute scalarized
179 references automatically. */
180 gfc_init_se (&argse
, se
);
182 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
184 gfc_conv_expr (&argse
, actual
->expr
);
185 gfc_conv_string_parameter (&argse
);
186 args
= gfc_chainon_list (args
, argse
.string_length
);
189 gfc_conv_expr_val (&argse
, actual
->expr
);
191 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
192 gfc_add_block_to_block (&se
->post
, &argse
.post
);
193 args
= gfc_chainon_list (args
, argse
.expr
);
199 /* Conversions between different types are output by the frontend as
200 intrinsic functions. We implement these directly with inline code. */
203 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
208 /* Evaluate the argument. */
209 type
= gfc_typenode_for_spec (&expr
->ts
);
210 gcc_assert (expr
->value
.function
.actual
->expr
);
211 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
212 arg
= TREE_VALUE (arg
);
214 /* Conversion from complex to non-complex involves taking the real
215 component of the value. */
216 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
217 && expr
->ts
.type
!= BT_COMPLEX
)
221 artype
= TREE_TYPE (TREE_TYPE (arg
));
222 arg
= build1 (REALPART_EXPR
, artype
, arg
);
225 se
->expr
= convert (type
, arg
);
228 /* This is needed because the gcc backend only implements
229 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
230 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
231 Similarly for CEILING. */
234 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
241 argtype
= TREE_TYPE (arg
);
242 arg
= gfc_evaluate_now (arg
, pblock
);
244 intval
= convert (type
, arg
);
245 intval
= gfc_evaluate_now (intval
, pblock
);
247 tmp
= convert (argtype
, intval
);
248 cond
= build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
250 tmp
= build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
251 build_int_cst (type
, 1));
252 tmp
= build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
257 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
258 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
261 build_round_expr (stmtblock_t
* pblock
, tree arg
, tree type
)
270 argtype
= TREE_TYPE (arg
);
271 arg
= gfc_evaluate_now (arg
, pblock
);
273 real_from_string (&r
, "0.5");
274 pos
= build_real (argtype
, r
);
276 real_from_string (&r
, "-0.5");
277 neg
= build_real (argtype
, r
);
279 tmp
= gfc_build_const (argtype
, integer_zero_node
);
280 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
282 tmp
= fold_build3 (COND_EXPR
, argtype
, cond
, pos
, neg
);
283 tmp
= fold_build2 (PLUS_EXPR
, argtype
, arg
, tmp
);
284 return fold_build1 (FIX_TRUNC_EXPR
, type
, tmp
);
288 /* Convert a real to an integer using a specific rounding mode.
289 Ideally we would just build the corresponding GENERIC node,
290 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
293 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
299 return build_fixbound_expr (pblock
, arg
, type
, 0);
303 return build_fixbound_expr (pblock
, arg
, type
, 1);
307 return build_round_expr (pblock
, arg
, type
);
310 return build1 (op
, type
, arg
);
315 /* Round a real value using the specified rounding mode.
316 We use a temporary integer of that same kind size as the result.
317 Values larger than those that can be represented by this kind are
318 unchanged, as thay will not be accurate enough to represent the
320 huge = HUGE (KIND (a))
321 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
325 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
336 kind
= expr
->ts
.kind
;
339 /* We have builtin functions for some cases. */
382 /* Evaluate the argument. */
383 gcc_assert (expr
->value
.function
.actual
->expr
);
384 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
386 /* Use a builtin function if one exists. */
387 if (n
!= END_BUILTINS
)
389 tmp
= built_in_decls
[n
];
390 se
->expr
= build_function_call_expr (tmp
, arg
);
394 /* This code is probably redundant, but we'll keep it lying around just
396 type
= gfc_typenode_for_spec (&expr
->ts
);
397 arg
= TREE_VALUE (arg
);
398 arg
= gfc_evaluate_now (arg
, &se
->pre
);
400 /* Test if the value is too large to handle sensibly. */
401 gfc_set_model_kind (kind
);
403 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
404 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
405 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
406 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
408 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
409 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
410 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
411 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
412 itype
= gfc_get_int_type (kind
);
414 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
415 tmp
= convert (type
, tmp
);
416 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
421 /* Convert to an integer using the specified rounding mode. */
424 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, int op
)
429 /* Evaluate the argument. */
430 type
= gfc_typenode_for_spec (&expr
->ts
);
431 gcc_assert (expr
->value
.function
.actual
->expr
);
432 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
433 arg
= TREE_VALUE (arg
);
435 if (TREE_CODE (TREE_TYPE (arg
)) == INTEGER_TYPE
)
437 /* Conversion to a different integer kind. */
438 se
->expr
= convert (type
, arg
);
442 /* Conversion from complex to non-complex involves taking the real
443 component of the value. */
444 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
445 && expr
->ts
.type
!= BT_COMPLEX
)
449 artype
= TREE_TYPE (TREE_TYPE (arg
));
450 arg
= build1 (REALPART_EXPR
, artype
, arg
);
453 se
->expr
= build_fix_expr (&se
->pre
, arg
, type
, op
);
458 /* Get the imaginary component of a value. */
461 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
465 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
466 arg
= TREE_VALUE (arg
);
467 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
471 /* Get the complex conjugate of a value. */
474 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
478 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
479 arg
= TREE_VALUE (arg
);
480 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
484 /* Initialize function decls for library functions. The external functions
485 are created as required. Builtin functions are added here. */
488 gfc_build_intrinsic_lib_fndecls (void)
490 gfc_intrinsic_map_t
*m
;
492 /* Add GCC builtin functions. */
493 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
495 if (m
->code_r4
!= END_BUILTINS
)
496 m
->real4_decl
= built_in_decls
[m
->code_r4
];
497 if (m
->code_r8
!= END_BUILTINS
)
498 m
->real8_decl
= built_in_decls
[m
->code_r8
];
499 if (m
->code_r10
!= END_BUILTINS
)
500 m
->real10_decl
= built_in_decls
[m
->code_r10
];
501 if (m
->code_r16
!= END_BUILTINS
)
502 m
->real16_decl
= built_in_decls
[m
->code_r16
];
503 if (m
->code_c4
!= END_BUILTINS
)
504 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
505 if (m
->code_c8
!= END_BUILTINS
)
506 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
507 if (m
->code_c10
!= END_BUILTINS
)
508 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
509 if (m
->code_c16
!= END_BUILTINS
)
510 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
515 /* Create a fndecl for a simple intrinsic library function. */
518 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
523 gfc_actual_arglist
*actual
;
526 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
529 if (ts
->type
== BT_REAL
)
534 pdecl
= &m
->real4_decl
;
537 pdecl
= &m
->real8_decl
;
540 pdecl
= &m
->real10_decl
;
543 pdecl
= &m
->real16_decl
;
549 else if (ts
->type
== BT_COMPLEX
)
551 gcc_assert (m
->complex_available
);
556 pdecl
= &m
->complex4_decl
;
559 pdecl
= &m
->complex8_decl
;
562 pdecl
= &m
->complex10_decl
;
565 pdecl
= &m
->complex16_decl
;
579 gcc_assert (ts
->kind
== 4 || ts
->kind
== 8 || ts
->kind
== 10
581 snprintf (name
, sizeof (name
), "%s%s%s",
582 ts
->type
== BT_COMPLEX
? "c" : "",
584 ts
->kind
== 4 ? "f" : "");
588 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
589 ts
->type
== BT_COMPLEX
? 'c' : 'r',
593 argtypes
= NULL_TREE
;
594 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
596 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
597 argtypes
= gfc_chainon_list (argtypes
, type
);
599 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
600 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
601 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
603 /* Mark the decl as external. */
604 DECL_EXTERNAL (fndecl
) = 1;
605 TREE_PUBLIC (fndecl
) = 1;
607 /* Mark it __attribute__((const)), if possible. */
608 TREE_READONLY (fndecl
) = m
->is_constant
;
610 rest_of_decl_compilation (fndecl
, 1, 0);
617 /* Convert an intrinsic function into an external or builtin call. */
620 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
622 gfc_intrinsic_map_t
*m
;
625 gfc_generic_isym_id id
;
627 id
= expr
->value
.function
.isym
->generic_id
;
628 /* Find the entry for this function. */
629 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
635 if (m
->id
== GFC_ISYM_NONE
)
637 internal_error ("Intrinsic function %s(%d) not recognized",
638 expr
->value
.function
.name
, id
);
641 /* Get the decl and generate the call. */
642 args
= gfc_conv_intrinsic_function_args (se
, expr
);
643 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
644 se
->expr
= build_function_call_expr (fndecl
, args
);
647 /* Generate code for EXPONENT(X) intrinsic function. */
650 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
655 args
= gfc_conv_intrinsic_function_args (se
, expr
);
657 a1
= expr
->value
.function
.actual
->expr
;
661 fndecl
= gfor_fndecl_math_exponent4
;
664 fndecl
= gfor_fndecl_math_exponent8
;
667 fndecl
= gfor_fndecl_math_exponent10
;
670 fndecl
= gfor_fndecl_math_exponent16
;
676 se
->expr
= build_function_call_expr (fndecl
, args
);
679 /* Evaluate a single upper or lower bound. */
680 /* TODO: bound intrinsic generates way too much unnecessary code. */
683 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
685 gfc_actual_arglist
*arg
;
686 gfc_actual_arglist
*arg2
;
696 arg
= expr
->value
.function
.actual
;
701 /* Create an implicit second parameter from the loop variable. */
702 gcc_assert (!arg2
->expr
);
703 gcc_assert (se
->loop
->dimen
== 1);
704 gcc_assert (se
->ss
->expr
== expr
);
705 gfc_advance_se_ss_chain (se
);
706 bound
= se
->loop
->loopvar
[0];
707 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
712 /* use the passed argument. */
713 gcc_assert (arg
->next
->expr
);
714 gfc_init_se (&argse
, NULL
);
715 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
716 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
718 /* Convert from one based to zero based. */
719 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
723 /* TODO: don't re-evaluate the descriptor on each iteration. */
724 /* Get a descriptor for the first parameter. */
725 ss
= gfc_walk_expr (arg
->expr
);
726 gcc_assert (ss
!= gfc_ss_terminator
);
727 gfc_init_se (&argse
, NULL
);
728 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
729 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
730 gfc_add_block_to_block (&se
->post
, &argse
.post
);
734 if (INTEGER_CST_P (bound
))
736 gcc_assert (TREE_INT_CST_HIGH (bound
) == 0);
737 i
= TREE_INT_CST_LOW (bound
);
738 gcc_assert (i
>= 0 && i
< GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)));
742 if (flag_bounds_check
)
744 bound
= gfc_evaluate_now (bound
, &se
->pre
);
745 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
746 bound
, build_int_cst (TREE_TYPE (bound
), 0));
747 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
748 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
749 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
750 gfc_trans_runtime_check (cond
, gfc_strconst_fault
, &se
->pre
);
755 se
->expr
= gfc_conv_descriptor_ubound(desc
, bound
);
757 se
->expr
= gfc_conv_descriptor_lbound(desc
, bound
);
759 type
= gfc_typenode_for_spec (&expr
->ts
);
760 se
->expr
= convert (type
, se
->expr
);
765 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
771 args
= gfc_conv_intrinsic_function_args (se
, expr
);
772 gcc_assert (args
&& TREE_CHAIN (args
) == NULL_TREE
);
773 val
= TREE_VALUE (args
);
775 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
779 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (val
), val
);
783 switch (expr
->ts
.kind
)
798 se
->expr
= build_function_call_expr (built_in_decls
[n
], args
);
807 /* Create a complex value from one or two real components. */
810 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
817 type
= gfc_typenode_for_spec (&expr
->ts
);
818 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
819 real
= convert (TREE_TYPE (type
), TREE_VALUE (arg
));
821 imag
= convert (TREE_TYPE (type
), TREE_VALUE (TREE_CHAIN (arg
)));
822 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg
))) == COMPLEX_TYPE
)
824 arg
= TREE_VALUE (arg
);
825 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
826 imag
= convert (TREE_TYPE (type
), imag
);
829 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
831 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
834 /* Remainder function MOD(A, P) = A - INT(A / P) * P
835 MODULO(A, P) = A - FLOOR (A / P) * P */
836 /* TODO: MOD(x, 0) */
839 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
851 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
852 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
853 arg
= TREE_VALUE (arg
);
854 type
= TREE_TYPE (arg
);
856 switch (expr
->ts
.type
)
859 /* Integer case is easy, we've got a builtin op. */
861 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, arg
, arg2
);
863 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, arg
, arg2
);
867 /* Real values we have to do the hard way. */
868 arg
= gfc_evaluate_now (arg
, &se
->pre
);
869 arg2
= gfc_evaluate_now (arg2
, &se
->pre
);
871 tmp
= build2 (RDIV_EXPR
, type
, arg
, arg2
);
872 /* Test if the value is too large to handle sensibly. */
873 gfc_set_model_kind (expr
->ts
.kind
);
875 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
876 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
877 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
878 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
880 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
881 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
882 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
883 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
885 itype
= gfc_get_int_type (expr
->ts
.kind
);
887 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_FLOOR_EXPR
);
889 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_TRUNC_EXPR
);
890 tmp
= convert (type
, tmp
);
891 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, arg
);
892 tmp
= build2 (MULT_EXPR
, type
, tmp
, arg2
);
893 se
->expr
= build2 (MINUS_EXPR
, type
, arg
, tmp
);
902 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
905 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
914 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
915 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
916 arg
= TREE_VALUE (arg
);
917 type
= TREE_TYPE (arg
);
919 val
= build2 (MINUS_EXPR
, type
, arg
, arg2
);
920 val
= gfc_evaluate_now (val
, &se
->pre
);
922 zero
= gfc_build_const (type
, integer_zero_node
);
923 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
924 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
928 /* SIGN(A, B) is absolute value of A times sign of B.
929 The real value versions use library functions to ensure the correct
930 handling of negative zero. Integer case implemented as:
931 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
935 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
946 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
947 if (expr
->ts
.type
== BT_REAL
)
949 switch (expr
->ts
.kind
)
952 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
955 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
959 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
964 se
->expr
= build_function_call_expr (tmp
, arg
);
968 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
969 arg
= TREE_VALUE (arg
);
970 type
= TREE_TYPE (arg
);
971 zero
= gfc_build_const (type
, integer_zero_node
);
973 testa
= fold_build2 (GE_EXPR
, boolean_type_node
, arg
, zero
);
974 testb
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
, zero
);
975 tmp
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, testa
, testb
);
976 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
,
977 build1 (NEGATE_EXPR
, type
, arg
), arg
);
981 /* Test for the presence of an optional argument. */
984 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
988 arg
= expr
->value
.function
.actual
->expr
;
989 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
990 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
991 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
995 /* Calculate the double precision product of two single precision values. */
998 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1004 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1005 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1006 arg
= TREE_VALUE (arg
);
1008 /* Convert the args to double precision before multiplying. */
1009 type
= gfc_typenode_for_spec (&expr
->ts
);
1010 arg
= convert (type
, arg
);
1011 arg2
= convert (type
, arg2
);
1012 se
->expr
= build2 (MULT_EXPR
, type
, arg
, arg2
);
1016 /* Return a length one character string containing an ascii character. */
1019 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1025 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1026 arg
= TREE_VALUE (arg
);
1028 /* We currently don't support character types != 1. */
1029 gcc_assert (expr
->ts
.kind
== 1);
1030 type
= gfc_character1_type_node
;
1031 var
= gfc_create_var (type
, "char");
1033 arg
= convert (type
, arg
);
1034 gfc_add_modify_expr (&se
->pre
, var
, arg
);
1035 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1036 se
->string_length
= integer_one_node
;
1041 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1049 tree gfc_int8_type_node
= gfc_get_int_type (8);
1051 type
= build_pointer_type (gfc_character1_type_node
);
1052 var
= gfc_create_var (type
, "pstr");
1053 len
= gfc_create_var (gfc_int8_type_node
, "len");
1055 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1056 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1057 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1058 arglist
= chainon (arglist
, tmp
);
1060 tmp
= build_function_call_expr (gfor_fndecl_ctime
, arglist
);
1061 gfc_add_expr_to_block (&se
->pre
, tmp
);
1063 /* Free the temporary afterwards, if necessary. */
1064 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1065 build_int_cst (TREE_TYPE (len
), 0));
1066 arglist
= gfc_chainon_list (NULL_TREE
, var
);
1067 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
1068 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1069 gfc_add_expr_to_block (&se
->post
, tmp
);
1072 se
->string_length
= len
;
1077 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1085 tree gfc_int4_type_node
= gfc_get_int_type (4);
1087 type
= build_pointer_type (gfc_character1_type_node
);
1088 var
= gfc_create_var (type
, "pstr");
1089 len
= gfc_create_var (gfc_int4_type_node
, "len");
1091 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1092 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1093 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1094 arglist
= chainon (arglist
, tmp
);
1096 tmp
= build_function_call_expr (gfor_fndecl_fdate
, arglist
);
1097 gfc_add_expr_to_block (&se
->pre
, tmp
);
1099 /* Free the temporary afterwards, if necessary. */
1100 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1101 build_int_cst (TREE_TYPE (len
), 0));
1102 arglist
= gfc_chainon_list (NULL_TREE
, var
);
1103 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
1104 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1105 gfc_add_expr_to_block (&se
->post
, tmp
);
1108 se
->string_length
= len
;
1112 /* Return a character string containing the tty name. */
1115 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1123 tree gfc_int4_type_node
= gfc_get_int_type (4);
1125 type
= build_pointer_type (gfc_character1_type_node
);
1126 var
= gfc_create_var (type
, "pstr");
1127 len
= gfc_create_var (gfc_int4_type_node
, "len");
1129 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1130 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1131 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1132 arglist
= chainon (arglist
, tmp
);
1134 tmp
= build_function_call_expr (gfor_fndecl_ttynam
, arglist
);
1135 gfc_add_expr_to_block (&se
->pre
, tmp
);
1137 /* Free the temporary afterwards, if necessary. */
1138 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1139 build_int_cst (TREE_TYPE (len
), 0));
1140 arglist
= gfc_chainon_list (NULL_TREE
, var
);
1141 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
1142 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1143 gfc_add_expr_to_block (&se
->post
, tmp
);
1146 se
->string_length
= len
;
1150 /* Get the minimum/maximum value of all the parameters.
1151 minmax (a1, a2, a3, ...)
1164 /* TODO: Mismatching types can occur when specific names are used.
1165 These should be handled during resolution. */
1167 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1178 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1179 type
= gfc_typenode_for_spec (&expr
->ts
);
1181 limit
= TREE_VALUE (arg
);
1182 if (TREE_TYPE (limit
) != type
)
1183 limit
= convert (type
, limit
);
1184 /* Only evaluate the argument once. */
1185 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1186 limit
= gfc_evaluate_now(limit
, &se
->pre
);
1188 mvar
= gfc_create_var (type
, "M");
1189 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1190 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1192 val
= TREE_VALUE (arg
);
1193 if (TREE_TYPE (val
) != type
)
1194 val
= convert (type
, val
);
1196 /* Only evaluate the argument once. */
1197 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1198 val
= gfc_evaluate_now(val
, &se
->pre
);
1200 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1202 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1203 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1204 gfc_add_expr_to_block (&se
->pre
, tmp
);
1205 elsecase
= build_empty_stmt ();
1212 /* Create a symbol node for this intrinsic. The symbol from the frontend
1213 has the generic name. */
1216 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1220 /* TODO: Add symbols for intrinsic function to the global namespace. */
1221 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1222 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1225 sym
->attr
.external
= 1;
1226 sym
->attr
.function
= 1;
1227 sym
->attr
.always_explicit
= 1;
1228 sym
->attr
.proc
= PROC_INTRINSIC
;
1229 sym
->attr
.flavor
= FL_PROCEDURE
;
1233 sym
->attr
.dimension
= 1;
1234 sym
->as
= gfc_get_array_spec ();
1235 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1236 sym
->as
->rank
= expr
->rank
;
1239 /* TODO: proper argument lists for external intrinsics. */
1243 /* Generate a call to an external intrinsic function. */
1245 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1249 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1252 gcc_assert (expr
->rank
> 0);
1254 gcc_assert (expr
->rank
== 0);
1256 sym
= gfc_get_symbol_for_expr (expr
);
1257 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1261 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1281 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1290 gfc_actual_arglist
*actual
;
1297 gfc_conv_intrinsic_funcall (se
, expr
);
1301 actual
= expr
->value
.function
.actual
;
1302 type
= gfc_typenode_for_spec (&expr
->ts
);
1303 /* Initialize the result. */
1304 resvar
= gfc_create_var (type
, "test");
1306 tmp
= convert (type
, boolean_true_node
);
1308 tmp
= convert (type
, boolean_false_node
);
1309 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1311 /* Walk the arguments. */
1312 arrayss
= gfc_walk_expr (actual
->expr
);
1313 gcc_assert (arrayss
!= gfc_ss_terminator
);
1315 /* Initialize the scalarizer. */
1316 gfc_init_loopinfo (&loop
);
1317 exit_label
= gfc_build_label_decl (NULL_TREE
);
1318 TREE_USED (exit_label
) = 1;
1319 gfc_add_ss_to_loop (&loop
, arrayss
);
1321 /* Initialize the loop. */
1322 gfc_conv_ss_startstride (&loop
);
1323 gfc_conv_loop_setup (&loop
);
1325 gfc_mark_ss_chain_used (arrayss
, 1);
1326 /* Generate the loop body. */
1327 gfc_start_scalarized_body (&loop
, &body
);
1329 /* If the condition matches then set the return value. */
1330 gfc_start_block (&block
);
1332 tmp
= convert (type
, boolean_false_node
);
1334 tmp
= convert (type
, boolean_true_node
);
1335 gfc_add_modify_expr (&block
, resvar
, tmp
);
1337 /* And break out of the loop. */
1338 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1339 gfc_add_expr_to_block (&block
, tmp
);
1341 found
= gfc_finish_block (&block
);
1343 /* Check this element. */
1344 gfc_init_se (&arrayse
, NULL
);
1345 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1346 arrayse
.ss
= arrayss
;
1347 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1349 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1350 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
,
1351 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1352 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1353 gfc_add_expr_to_block (&body
, tmp
);
1354 gfc_add_block_to_block (&body
, &arrayse
.post
);
1356 gfc_trans_scalarizing_loops (&loop
, &body
);
1358 /* Add the exit label. */
1359 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1360 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1362 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1363 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1364 gfc_cleanup_loop (&loop
);
1369 /* COUNT(A) = Number of true elements in A. */
1371 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1378 gfc_actual_arglist
*actual
;
1384 gfc_conv_intrinsic_funcall (se
, expr
);
1388 actual
= expr
->value
.function
.actual
;
1390 type
= gfc_typenode_for_spec (&expr
->ts
);
1391 /* Initialize the result. */
1392 resvar
= gfc_create_var (type
, "count");
1393 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1395 /* Walk the arguments. */
1396 arrayss
= gfc_walk_expr (actual
->expr
);
1397 gcc_assert (arrayss
!= gfc_ss_terminator
);
1399 /* Initialize the scalarizer. */
1400 gfc_init_loopinfo (&loop
);
1401 gfc_add_ss_to_loop (&loop
, arrayss
);
1403 /* Initialize the loop. */
1404 gfc_conv_ss_startstride (&loop
);
1405 gfc_conv_loop_setup (&loop
);
1407 gfc_mark_ss_chain_used (arrayss
, 1);
1408 /* Generate the loop body. */
1409 gfc_start_scalarized_body (&loop
, &body
);
1411 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1412 build_int_cst (TREE_TYPE (resvar
), 1));
1413 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1415 gfc_init_se (&arrayse
, NULL
);
1416 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1417 arrayse
.ss
= arrayss
;
1418 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1419 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1421 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1422 gfc_add_expr_to_block (&body
, tmp
);
1423 gfc_add_block_to_block (&body
, &arrayse
.post
);
1425 gfc_trans_scalarizing_loops (&loop
, &body
);
1427 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1428 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1429 gfc_cleanup_loop (&loop
);
1434 /* Inline implementation of the sum and product intrinsics. */
1436 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1444 gfc_actual_arglist
*actual
;
1449 gfc_expr
*arrayexpr
;
1454 gfc_conv_intrinsic_funcall (se
, expr
);
1458 type
= gfc_typenode_for_spec (&expr
->ts
);
1459 /* Initialize the result. */
1460 resvar
= gfc_create_var (type
, "val");
1461 if (op
== PLUS_EXPR
)
1462 tmp
= gfc_build_const (type
, integer_zero_node
);
1464 tmp
= gfc_build_const (type
, integer_one_node
);
1466 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1468 /* Walk the arguments. */
1469 actual
= expr
->value
.function
.actual
;
1470 arrayexpr
= actual
->expr
;
1471 arrayss
= gfc_walk_expr (arrayexpr
);
1472 gcc_assert (arrayss
!= gfc_ss_terminator
);
1474 actual
= actual
->next
->next
;
1475 gcc_assert (actual
);
1476 maskexpr
= actual
->expr
;
1477 if (maskexpr
&& maskexpr
->rank
!= 0)
1479 maskss
= gfc_walk_expr (maskexpr
);
1480 gcc_assert (maskss
!= gfc_ss_terminator
);
1485 /* Initialize the scalarizer. */
1486 gfc_init_loopinfo (&loop
);
1487 gfc_add_ss_to_loop (&loop
, arrayss
);
1489 gfc_add_ss_to_loop (&loop
, maskss
);
1491 /* Initialize the loop. */
1492 gfc_conv_ss_startstride (&loop
);
1493 gfc_conv_loop_setup (&loop
);
1495 gfc_mark_ss_chain_used (arrayss
, 1);
1497 gfc_mark_ss_chain_used (maskss
, 1);
1498 /* Generate the loop body. */
1499 gfc_start_scalarized_body (&loop
, &body
);
1501 /* If we have a mask, only add this element if the mask is set. */
1504 gfc_init_se (&maskse
, NULL
);
1505 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1507 gfc_conv_expr_val (&maskse
, maskexpr
);
1508 gfc_add_block_to_block (&body
, &maskse
.pre
);
1510 gfc_start_block (&block
);
1513 gfc_init_block (&block
);
1515 /* Do the actual summation/product. */
1516 gfc_init_se (&arrayse
, NULL
);
1517 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1518 arrayse
.ss
= arrayss
;
1519 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1520 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1522 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1523 gfc_add_modify_expr (&block
, resvar
, tmp
);
1524 gfc_add_block_to_block (&block
, &arrayse
.post
);
1528 /* We enclose the above in if (mask) {...} . */
1529 tmp
= gfc_finish_block (&block
);
1531 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1534 tmp
= gfc_finish_block (&block
);
1535 gfc_add_expr_to_block (&body
, tmp
);
1537 gfc_trans_scalarizing_loops (&loop
, &body
);
1539 /* For a scalar mask, enclose the loop in an if statement. */
1540 if (maskexpr
&& maskss
== NULL
)
1542 gfc_init_se (&maskse
, NULL
);
1543 gfc_conv_expr_val (&maskse
, maskexpr
);
1544 gfc_init_block (&block
);
1545 gfc_add_block_to_block (&block
, &loop
.pre
);
1546 gfc_add_block_to_block (&block
, &loop
.post
);
1547 tmp
= gfc_finish_block (&block
);
1549 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1550 gfc_add_expr_to_block (&block
, tmp
);
1551 gfc_add_block_to_block (&se
->pre
, &block
);
1555 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1556 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1559 gfc_cleanup_loop (&loop
);
1565 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1569 stmtblock_t ifblock
;
1570 stmtblock_t elseblock
;
1578 gfc_actual_arglist
*actual
;
1583 gfc_expr
*arrayexpr
;
1590 gfc_conv_intrinsic_funcall (se
, expr
);
1594 /* Initialize the result. */
1595 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1596 type
= gfc_typenode_for_spec (&expr
->ts
);
1598 /* Walk the arguments. */
1599 actual
= expr
->value
.function
.actual
;
1600 arrayexpr
= actual
->expr
;
1601 arrayss
= gfc_walk_expr (arrayexpr
);
1602 gcc_assert (arrayss
!= gfc_ss_terminator
);
1604 actual
= actual
->next
->next
;
1605 gcc_assert (actual
);
1606 maskexpr
= actual
->expr
;
1607 if (maskexpr
&& maskexpr
->rank
!= 0)
1609 maskss
= gfc_walk_expr (maskexpr
);
1610 gcc_assert (maskss
!= gfc_ss_terminator
);
1615 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1616 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1617 switch (arrayexpr
->ts
.type
)
1620 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1624 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1625 arrayexpr
->ts
.kind
);
1632 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1634 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1635 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1637 /* Initialize the scalarizer. */
1638 gfc_init_loopinfo (&loop
);
1639 gfc_add_ss_to_loop (&loop
, arrayss
);
1641 gfc_add_ss_to_loop (&loop
, maskss
);
1643 /* Initialize the loop. */
1644 gfc_conv_ss_startstride (&loop
);
1645 gfc_conv_loop_setup (&loop
);
1647 gcc_assert (loop
.dimen
== 1);
1649 /* Initialize the position to the first element. If the array has zero
1650 size we need to return zero. Otherwise use the first element of the
1651 array, in case all elements are equal to the limit.
1652 i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1653 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1654 loop
.from
[0], gfc_index_one_node
);
1655 cond
= fold_build2 (GE_EXPR
, boolean_type_node
,
1656 loop
.to
[0], loop
.from
[0]);
1657 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1659 gfc_add_modify_expr (&loop
.pre
, pos
, tmp
);
1661 gfc_mark_ss_chain_used (arrayss
, 1);
1663 gfc_mark_ss_chain_used (maskss
, 1);
1664 /* Generate the loop body. */
1665 gfc_start_scalarized_body (&loop
, &body
);
1667 /* If we have a mask, only check this element if the mask is set. */
1670 gfc_init_se (&maskse
, NULL
);
1671 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1673 gfc_conv_expr_val (&maskse
, maskexpr
);
1674 gfc_add_block_to_block (&body
, &maskse
.pre
);
1676 gfc_start_block (&block
);
1679 gfc_init_block (&block
);
1681 /* Compare with the current limit. */
1682 gfc_init_se (&arrayse
, NULL
);
1683 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1684 arrayse
.ss
= arrayss
;
1685 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1686 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1688 /* We do the following if this is a more extreme value. */
1689 gfc_start_block (&ifblock
);
1691 /* Assign the value to the limit... */
1692 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
1694 /* Remember where we are. */
1695 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
1697 ifbody
= gfc_finish_block (&ifblock
);
1699 /* If it is a more extreme value. */
1700 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1701 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1702 gfc_add_expr_to_block (&block
, tmp
);
1706 /* We enclose the above in if (mask) {...}. */
1707 tmp
= gfc_finish_block (&block
);
1709 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1712 tmp
= gfc_finish_block (&block
);
1713 gfc_add_expr_to_block (&body
, tmp
);
1715 gfc_trans_scalarizing_loops (&loop
, &body
);
1717 /* For a scalar mask, enclose the loop in an if statement. */
1718 if (maskexpr
&& maskss
== NULL
)
1720 gfc_init_se (&maskse
, NULL
);
1721 gfc_conv_expr_val (&maskse
, maskexpr
);
1722 gfc_init_block (&block
);
1723 gfc_add_block_to_block (&block
, &loop
.pre
);
1724 gfc_add_block_to_block (&block
, &loop
.post
);
1725 tmp
= gfc_finish_block (&block
);
1727 /* For the else part of the scalar mask, just initialize
1728 the pos variable the same way as above. */
1730 gfc_init_block (&elseblock
);
1732 elsetmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1733 loop
.from
[0], gfc_index_one_node
);
1734 cond
= fold_build2 (GE_EXPR
, boolean_type_node
,
1735 loop
.to
[0], loop
.from
[0]);
1736 elsetmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1737 loop
.from
[0], elsetmp
);
1738 gfc_add_modify_expr (&elseblock
, pos
, elsetmp
);
1739 elsetmp
= gfc_finish_block (&elseblock
);
1741 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
1742 gfc_add_expr_to_block (&block
, tmp
);
1743 gfc_add_block_to_block (&se
->pre
, &block
);
1747 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1748 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1750 gfc_cleanup_loop (&loop
);
1752 /* Return a value in the range 1..SIZE(array). */
1753 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
1754 gfc_index_one_node
);
1755 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
);
1756 /* And convert to the required type. */
1757 se
->expr
= convert (type
, tmp
);
1761 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
1770 gfc_actual_arglist
*actual
;
1775 gfc_expr
*arrayexpr
;
1781 gfc_conv_intrinsic_funcall (se
, expr
);
1785 type
= gfc_typenode_for_spec (&expr
->ts
);
1786 /* Initialize the result. */
1787 limit
= gfc_create_var (type
, "limit");
1788 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
1789 switch (expr
->ts
.type
)
1792 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
1796 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
1803 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1805 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1806 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1808 /* Walk the arguments. */
1809 actual
= expr
->value
.function
.actual
;
1810 arrayexpr
= actual
->expr
;
1811 arrayss
= gfc_walk_expr (arrayexpr
);
1812 gcc_assert (arrayss
!= gfc_ss_terminator
);
1814 actual
= actual
->next
->next
;
1815 gcc_assert (actual
);
1816 maskexpr
= actual
->expr
;
1817 if (maskexpr
&& maskexpr
->rank
!= 0)
1819 maskss
= gfc_walk_expr (maskexpr
);
1820 gcc_assert (maskss
!= gfc_ss_terminator
);
1825 /* Initialize the scalarizer. */
1826 gfc_init_loopinfo (&loop
);
1827 gfc_add_ss_to_loop (&loop
, arrayss
);
1829 gfc_add_ss_to_loop (&loop
, maskss
);
1831 /* Initialize the loop. */
1832 gfc_conv_ss_startstride (&loop
);
1833 gfc_conv_loop_setup (&loop
);
1835 gfc_mark_ss_chain_used (arrayss
, 1);
1837 gfc_mark_ss_chain_used (maskss
, 1);
1838 /* Generate the loop body. */
1839 gfc_start_scalarized_body (&loop
, &body
);
1841 /* If we have a mask, only add this element if the mask is set. */
1844 gfc_init_se (&maskse
, NULL
);
1845 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1847 gfc_conv_expr_val (&maskse
, maskexpr
);
1848 gfc_add_block_to_block (&body
, &maskse
.pre
);
1850 gfc_start_block (&block
);
1853 gfc_init_block (&block
);
1855 /* Compare with the current limit. */
1856 gfc_init_se (&arrayse
, NULL
);
1857 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1858 arrayse
.ss
= arrayss
;
1859 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1860 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1862 /* Assign the value to the limit... */
1863 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
1865 /* If it is a more extreme value. */
1866 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1867 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1868 gfc_add_expr_to_block (&block
, tmp
);
1869 gfc_add_block_to_block (&block
, &arrayse
.post
);
1871 tmp
= gfc_finish_block (&block
);
1873 /* We enclose the above in if (mask) {...}. */
1874 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1875 gfc_add_expr_to_block (&body
, tmp
);
1877 gfc_trans_scalarizing_loops (&loop
, &body
);
1879 /* For a scalar mask, enclose the loop in an if statement. */
1880 if (maskexpr
&& maskss
== NULL
)
1882 gfc_init_se (&maskse
, NULL
);
1883 gfc_conv_expr_val (&maskse
, maskexpr
);
1884 gfc_init_block (&block
);
1885 gfc_add_block_to_block (&block
, &loop
.pre
);
1886 gfc_add_block_to_block (&block
, &loop
.post
);
1887 tmp
= gfc_finish_block (&block
);
1889 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1890 gfc_add_expr_to_block (&block
, tmp
);
1891 gfc_add_block_to_block (&se
->pre
, &block
);
1895 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1896 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1899 gfc_cleanup_loop (&loop
);
1904 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1906 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
1913 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1914 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1915 arg
= TREE_VALUE (arg
);
1916 type
= TREE_TYPE (arg
);
1918 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1919 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
1920 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
1921 build_int_cst (type
, 0));
1922 type
= gfc_typenode_for_spec (&expr
->ts
);
1923 se
->expr
= convert (type
, tmp
);
1926 /* Generate code to perform the specified operation. */
1928 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
1934 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1935 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1936 arg
= TREE_VALUE (arg
);
1937 type
= TREE_TYPE (arg
);
1939 se
->expr
= fold_build2 (op
, type
, arg
, arg2
);
1944 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
1948 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1949 arg
= TREE_VALUE (arg
);
1951 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
1954 /* Set or clear a single bit. */
1956 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
1964 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1965 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1966 arg
= TREE_VALUE (arg
);
1967 type
= TREE_TYPE (arg
);
1969 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1975 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
1977 se
->expr
= fold_build2 (op
, type
, arg
, tmp
);
1980 /* Extract a sequence of bits.
1981 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1983 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
1992 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1993 arg2
= TREE_CHAIN (arg
);
1994 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
1995 arg
= TREE_VALUE (arg
);
1996 arg2
= TREE_VALUE (arg2
);
1997 type
= TREE_TYPE (arg
);
1999 mask
= build_int_cst (NULL_TREE
, -1);
2000 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
2001 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
2003 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
2005 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2008 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2010 : ((shift >= 0) ? i << shift : i >> -shift)
2011 where all shifts are logical shifts. */
2013 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2026 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2027 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2028 arg
= TREE_VALUE (arg
);
2029 type
= TREE_TYPE (arg
);
2030 utype
= gfc_unsigned_type (type
);
2032 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
);
2034 /* Left shift if positive. */
2035 lshift
= fold_build2 (LSHIFT_EXPR
, type
, arg
, width
);
2037 /* Right shift if negative.
2038 We convert to an unsigned type because we want a logical shift.
2039 The standard doesn't define the case of shifting negative
2040 numbers, and we try to be compatible with other compilers, most
2041 notably g77, here. */
2042 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
2043 convert (utype
, arg
), width
));
2045 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
,
2046 build_int_cst (TREE_TYPE (arg2
), 0));
2047 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2049 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2050 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2052 num_bits
= build_int_cst (TREE_TYPE (arg2
), TYPE_PRECISION (type
));
2053 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2055 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2056 build_int_cst (type
, 0), tmp
);
2059 /* Circular shift. AKA rotate or barrel shift. */
2061 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2072 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2073 arg2
= TREE_CHAIN (arg
);
2074 arg3
= TREE_CHAIN (arg2
);
2077 /* Use a library function for the 3 parameter version. */
2078 tree int4type
= gfc_get_int_type (4);
2080 type
= TREE_TYPE (TREE_VALUE (arg
));
2081 /* We convert the first argument to at least 4 bytes, and
2082 convert back afterwards. This removes the need for library
2083 functions for all argument sizes, and function will be
2084 aligned to at least 32 bits, so there's no loss. */
2085 if (expr
->ts
.kind
< 4)
2087 tmp
= convert (int4type
, TREE_VALUE (arg
));
2088 TREE_VALUE (arg
) = tmp
;
2090 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2091 need loads of library functions. They cannot have values >
2092 BIT_SIZE (I) so the conversion is safe. */
2093 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
2094 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
2096 switch (expr
->ts
.kind
)
2101 tmp
= gfor_fndecl_math_ishftc4
;
2104 tmp
= gfor_fndecl_math_ishftc8
;
2107 tmp
= gfor_fndecl_math_ishftc16
;
2112 se
->expr
= build_function_call_expr (tmp
, arg
);
2113 /* Convert the result back to the original type, if we extended
2114 the first argument's width above. */
2115 if (expr
->ts
.kind
< 4)
2116 se
->expr
= convert (type
, se
->expr
);
2120 arg
= TREE_VALUE (arg
);
2121 arg2
= TREE_VALUE (arg2
);
2122 type
= TREE_TYPE (arg
);
2124 /* Rotate left if positive. */
2125 lrot
= fold_build2 (LROTATE_EXPR
, type
, arg
, arg2
);
2127 /* Rotate right if negative. */
2128 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
2129 rrot
= fold_build2 (RROTATE_EXPR
, type
, arg
, tmp
);
2131 zero
= build_int_cst (TREE_TYPE (arg2
), 0);
2132 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
);
2133 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2135 /* Do nothing if shift == 0. */
2136 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg2
, zero
);
2137 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, arg
, rrot
);
2140 /* The length of a character string. */
2142 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2151 gcc_assert (!se
->ss
);
2153 arg
= expr
->value
.function
.actual
->expr
;
2155 type
= gfc_typenode_for_spec (&expr
->ts
);
2156 switch (arg
->expr_type
)
2159 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2163 if (arg
->expr_type
== EXPR_VARIABLE
2164 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
2165 && arg
->ref
->type
== REF_ARRAY
)))
2167 /* This doesn't catch all cases.
2168 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2169 and the surrounding thread. */
2170 sym
= arg
->symtree
->n
.sym
;
2171 decl
= gfc_get_symbol_decl (sym
);
2172 if (decl
== current_function_decl
&& sym
->attr
.function
2173 && (sym
->result
== sym
))
2174 decl
= gfc_get_fake_result_decl (sym
);
2176 len
= sym
->ts
.cl
->backend_decl
;
2181 /* Anybody stupid enough to do this deserves inefficient code. */
2182 gfc_init_se (&argse
, se
);
2183 gfc_conv_expr (&argse
, arg
);
2184 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2185 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2186 len
= argse
.string_length
;
2190 se
->expr
= convert (type
, len
);
2193 /* The length of a character string not including trailing blanks. */
2195 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2200 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2201 type
= gfc_typenode_for_spec (&expr
->ts
);
2202 se
->expr
= build_function_call_expr (gfor_fndecl_string_len_trim
, args
);
2203 se
->expr
= convert (type
, se
->expr
);
2207 /* Returns the starting position of a substring within a string. */
2210 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
2212 tree logical4_type_node
= gfc_get_logical_type (4);
2218 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2219 type
= gfc_typenode_for_spec (&expr
->ts
);
2220 tmp
= gfc_advance_chain (args
, 3);
2221 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2223 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2225 TREE_CHAIN (tmp
) = back
;
2229 back
= TREE_CHAIN (tmp
);
2230 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2233 se
->expr
= build_function_call_expr (gfor_fndecl_string_index
, args
);
2234 se
->expr
= convert (type
, se
->expr
);
2237 /* The ascii value for a single character. */
2239 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2244 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2245 arg
= TREE_VALUE (TREE_CHAIN (arg
));
2246 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
2247 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
2248 type
= gfc_typenode_for_spec (&expr
->ts
);
2250 se
->expr
= build_fold_indirect_ref (arg
);
2251 se
->expr
= convert (type
, se
->expr
);
2255 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2258 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2267 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2268 if (expr
->ts
.type
!= BT_CHARACTER
)
2270 tsource
= TREE_VALUE (arg
);
2271 arg
= TREE_CHAIN (arg
);
2272 fsource
= TREE_VALUE (arg
);
2273 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2277 /* We do the same as in the non-character case, but the argument
2278 list is different because of the string length arguments. We
2279 also have to set the string length for the result. */
2280 len
= TREE_VALUE (arg
);
2281 arg
= TREE_CHAIN (arg
);
2282 tsource
= TREE_VALUE (arg
);
2283 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2284 fsource
= TREE_VALUE (arg
);
2285 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2287 se
->string_length
= len
;
2289 type
= TREE_TYPE (tsource
);
2290 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2295 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2297 gfc_actual_arglist
*actual
;
2304 gfc_init_se (&argse
, NULL
);
2305 actual
= expr
->value
.function
.actual
;
2307 ss
= gfc_walk_expr (actual
->expr
);
2308 gcc_assert (ss
!= gfc_ss_terminator
);
2309 argse
.want_pointer
= 1;
2310 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2311 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2312 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2313 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2315 actual
= actual
->next
;
2318 gfc_init_se (&argse
, NULL
);
2319 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2320 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2321 args
= gfc_chainon_list (args
, argse
.expr
);
2322 fndecl
= gfor_fndecl_size1
;
2325 fndecl
= gfor_fndecl_size0
;
2327 se
->expr
= build_function_call_expr (fndecl
, args
);
2328 type
= gfc_typenode_for_spec (&expr
->ts
);
2329 se
->expr
= convert (type
, se
->expr
);
2333 /* Intrinsic string comparison functions. */
2336 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2342 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2343 arg2
= TREE_CHAIN (TREE_CHAIN (args
));
2345 se
->expr
= gfc_build_compare_string (TREE_VALUE (args
),
2346 TREE_VALUE (TREE_CHAIN (args
)), TREE_VALUE (arg2
),
2347 TREE_VALUE (TREE_CHAIN (arg2
)));
2349 type
= gfc_typenode_for_spec (&expr
->ts
);
2350 se
->expr
= fold_build2 (op
, type
, se
->expr
,
2351 build_int_cst (TREE_TYPE (se
->expr
), 0));
2354 /* Generate a call to the adjustl/adjustr library function. */
2356 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2364 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2365 len
= TREE_VALUE (args
);
2367 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2368 var
= gfc_conv_string_tmp (se
, type
, len
);
2369 args
= tree_cons (NULL_TREE
, var
, args
);
2371 tmp
= build_function_call_expr (fndecl
, args
);
2372 gfc_add_expr_to_block (&se
->pre
, tmp
);
2374 se
->string_length
= len
;
2378 /* Scalar transfer statement.
2379 TRANSFER (source, mold) = *(typeof<mold> *)&source. */
2382 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2384 gfc_actual_arglist
*arg
;
2390 gcc_assert (!se
->ss
);
2392 /* Get a pointer to the source. */
2393 arg
= expr
->value
.function
.actual
;
2394 ss
= gfc_walk_expr (arg
->expr
);
2395 gfc_init_se (&argse
, NULL
);
2396 if (ss
== gfc_ss_terminator
)
2397 gfc_conv_expr_reference (&argse
, arg
->expr
);
2399 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2400 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2401 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2405 type
= gfc_typenode_for_spec (&expr
->ts
);
2406 ptr
= convert (build_pointer_type (type
), ptr
);
2407 if (expr
->ts
.type
== BT_CHARACTER
)
2409 gfc_init_se (&argse
, NULL
);
2410 gfc_conv_expr (&argse
, arg
->expr
);
2411 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2412 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2414 se
->string_length
= argse
.string_length
;
2418 se
->expr
= build_fold_indirect_ref (ptr
);
2423 /* Generate code for the ALLOCATED intrinsic.
2424 Generate inline code that directly check the address of the argument. */
2427 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2429 gfc_actual_arglist
*arg1
;
2434 gfc_init_se (&arg1se
, NULL
);
2435 arg1
= expr
->value
.function
.actual
;
2436 ss1
= gfc_walk_expr (arg1
->expr
);
2437 arg1se
.descriptor_only
= 1;
2438 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2440 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
2441 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2442 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2443 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2447 /* Generate code for the ASSOCIATED intrinsic.
2448 If both POINTER and TARGET are arrays, generate a call to library function
2449 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2450 In other cases, generate inline code that directly compare the address of
2451 POINTER with the address of TARGET. */
2454 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2456 gfc_actual_arglist
*arg1
;
2457 gfc_actual_arglist
*arg2
;
2465 gfc_init_se (&arg1se
, NULL
);
2466 gfc_init_se (&arg2se
, NULL
);
2467 arg1
= expr
->value
.function
.actual
;
2469 ss1
= gfc_walk_expr (arg1
->expr
);
2473 /* No optional target. */
2474 if (ss1
== gfc_ss_terminator
)
2476 /* A pointer to a scalar. */
2477 arg1se
.want_pointer
= 1;
2478 gfc_conv_expr (&arg1se
, arg1
->expr
);
2483 /* A pointer to an array. */
2484 arg1se
.descriptor_only
= 1;
2485 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2486 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
2488 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2489 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2494 /* An optional target. */
2495 ss2
= gfc_walk_expr (arg2
->expr
);
2496 if (ss1
== gfc_ss_terminator
)
2498 /* A pointer to a scalar. */
2499 gcc_assert (ss2
== gfc_ss_terminator
);
2500 arg1se
.want_pointer
= 1;
2501 gfc_conv_expr (&arg1se
, arg1
->expr
);
2502 arg2se
.want_pointer
= 1;
2503 gfc_conv_expr (&arg2se
, arg2
->expr
);
2504 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2509 /* A pointer to an array, call library function _gfor_associated. */
2510 gcc_assert (ss2
!= gfc_ss_terminator
);
2512 arg1se
.want_pointer
= 1;
2513 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2514 args
= gfc_chainon_list (args
, arg1se
.expr
);
2515 arg2se
.want_pointer
= 1;
2516 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2517 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2518 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2519 args
= gfc_chainon_list (args
, arg2se
.expr
);
2520 fndecl
= gfor_fndecl_associated
;
2521 se
->expr
= build_function_call_expr (fndecl
, args
);
2524 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2528 /* Scan a string for any one of the characters in a set of characters. */
2531 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2533 tree logical4_type_node
= gfc_get_logical_type (4);
2539 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2540 type
= gfc_typenode_for_spec (&expr
->ts
);
2541 tmp
= gfc_advance_chain (args
, 3);
2542 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2544 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2546 TREE_CHAIN (tmp
) = back
;
2550 back
= TREE_CHAIN (tmp
);
2551 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2554 se
->expr
= build_function_call_expr (gfor_fndecl_string_scan
, args
);
2555 se
->expr
= convert (type
, se
->expr
);
2559 /* Verify that a set of characters contains all the characters in a string
2560 by identifying the position of the first character in a string of
2561 characters that does not appear in a given set of characters. */
2564 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2566 tree logical4_type_node
= gfc_get_logical_type (4);
2572 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2573 type
= gfc_typenode_for_spec (&expr
->ts
);
2574 tmp
= gfc_advance_chain (args
, 3);
2575 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2577 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2579 TREE_CHAIN (tmp
) = back
;
2583 back
= TREE_CHAIN (tmp
);
2584 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2587 se
->expr
= build_function_call_expr (gfor_fndecl_string_verify
, args
);
2588 se
->expr
= convert (type
, se
->expr
);
2591 /* Prepare components and related information of a real number which is
2592 the first argument of a elemental functions to manipulate reals. */
2595 prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2596 real_compnt_info
* rcs
, int all
)
2603 tree exponent
, fraction
;
2607 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2608 gfc_todo_error ("Non-IEEE floating format");
2610 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2612 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2613 arg
= TREE_VALUE (arg
);
2614 rcs
->type
= TREE_TYPE (arg
);
2616 /* Force arg'type to integer by unaffected convert */
2617 a1
= expr
->value
.function
.actual
->expr
;
2618 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2619 rcs
->mtype
= masktype
;
2620 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2621 arg
= gfc_create_var (masktype
, "arg");
2622 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2625 /* Calculate the numbers of bits of exponent, fraction and word */
2626 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2627 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2628 rcs
->fdigits
= convert (masktype
, tmp
);
2629 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2630 wbits
= convert (masktype
, wbits
);
2631 rcs
->edigits
= fold_build2 (MINUS_EXPR
, masktype
, wbits
, tmp
);
2633 /* Form masks for exponent/fraction/sign */
2634 one
= gfc_build_const (masktype
, integer_one_node
);
2635 rcs
->smask
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, wbits
);
2636 rcs
->f1
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
);
2637 rcs
->emask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
);
2638 rcs
->fmask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
);
2640 tmp
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
);
2641 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, tmp
);
2642 rcs
->bias
= fold_build2 (MINUS_EXPR
, masktype
, tmp
,one
);
2646 /* exponent, and fraction */
2647 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2648 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2649 exponent
= gfc_create_var (masktype
, "exponent");
2650 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2651 rcs
->expn
= exponent
;
2653 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2654 fraction
= gfc_create_var (masktype
, "fraction");
2655 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2656 rcs
->frac
= fraction
;
2660 /* Build a call to __builtin_clz. */
2663 call_builtin_clz (tree result_type
, tree op0
)
2665 tree fn
, parms
, call
;
2666 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2668 if (op0_mode
== TYPE_MODE (integer_type_node
))
2669 fn
= built_in_decls
[BUILT_IN_CLZ
];
2670 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2671 fn
= built_in_decls
[BUILT_IN_CLZL
];
2672 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2673 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2677 parms
= tree_cons (NULL
, op0
, NULL
);
2678 call
= build_function_call_expr (fn
, parms
);
2680 return convert (result_type
, call
);
2684 /* Generate code for SPACING (X) intrinsic function.
2685 SPACING (X) = POW (2, e-p)
2689 t = expn - fdigits // e - p.
2690 res = t << fdigits // Form the exponent. Fraction is zero.
2691 if (t < 0) // The result is out of range. Denormalized case.
2696 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2703 real_compnt_info rcs
;
2705 prepare_arg_info (se
, expr
, &rcs
, 0);
2707 masktype
= rcs
.mtype
;
2708 fdigits
= rcs
.fdigits
;
2710 zero
= gfc_build_const (masktype
, integer_zero_node
);
2711 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
2712 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2713 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
2714 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
2715 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2716 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
2717 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2722 /* Generate code for RRSPACING (X) intrinsic function.
2723 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2725 So the result's exponent is p. And if X is normalized, X's fraction part
2726 is the result's fraction. If X is denormalized, to get the X's fraction we
2727 shift X's fraction part to left until the first '1' is removed.
2731 if (expn == 0 && frac == 0)
2735 // edigits is the number of exponent bits. Add the sign bit.
2736 sedigits = edigits + 1;
2738 if (expn == 0) // Denormalized case.
2740 t1 = leadzero (frac);
2741 frac = frac << (t1 + 1); //Remove the first '1'.
2742 frac = frac >> (sedigits); //Form the fraction.
2745 //fdigits is the number of fraction bits. Form the exponent.
2748 res = (t << fdigits) | frac;
2753 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
2756 tree tmp
, t1
, t2
, cond
, cond2
;
2758 tree fdigits
, fraction
;
2759 real_compnt_info rcs
;
2761 prepare_arg_info (se
, expr
, &rcs
, 1);
2762 masktype
= rcs
.mtype
;
2763 fdigits
= rcs
.fdigits
;
2764 fraction
= rcs
.frac
;
2765 one
= gfc_build_const (masktype
, integer_one_node
);
2766 zero
= gfc_build_const (masktype
, integer_zero_node
);
2767 t2
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
);
2769 t1
= call_builtin_clz (masktype
, fraction
);
2770 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
2771 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
2772 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
2773 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
2774 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
2776 tmp
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
);
2777 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2778 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
2780 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
2781 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
2782 tmp
= build3 (COND_EXPR
, masktype
, cond
,
2783 build_int_cst (masktype
, 0), tmp
);
2785 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2789 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2792 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
2796 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2797 args
= TREE_VALUE (args
);
2798 args
= build_fold_addr_expr (args
);
2799 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
2800 se
->expr
= build_function_call_expr (gfor_fndecl_si_kind
, args
);
2803 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2806 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
2808 gfc_actual_arglist
*actual
;
2813 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2815 gfc_init_se (&argse
, se
);
2817 /* Pass a NULL pointer for an absent arg. */
2818 if (actual
->expr
== NULL
)
2819 argse
.expr
= null_pointer_node
;
2821 gfc_conv_expr_reference (&argse
, actual
->expr
);
2823 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2824 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2825 args
= gfc_chainon_list (args
, argse
.expr
);
2827 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
2831 /* Generate code for TRIM (A) intrinsic function. */
2834 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
2836 tree gfc_int4_type_node
= gfc_get_int_type (4);
2845 arglist
= NULL_TREE
;
2847 type
= build_pointer_type (gfc_character1_type_node
);
2848 var
= gfc_create_var (type
, "pstr");
2849 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
2850 len
= gfc_create_var (gfc_int4_type_node
, "len");
2852 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
2853 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
2854 arglist
= gfc_chainon_list (arglist
, addr
);
2855 arglist
= chainon (arglist
, tmp
);
2857 tmp
= build_function_call_expr (gfor_fndecl_string_trim
, arglist
);
2858 gfc_add_expr_to_block (&se
->pre
, tmp
);
2860 /* Free the temporary afterwards, if necessary. */
2861 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
2862 build_int_cst (TREE_TYPE (len
), 0));
2863 arglist
= gfc_chainon_list (NULL_TREE
, var
);
2864 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
2865 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2866 gfc_add_expr_to_block (&se
->post
, tmp
);
2869 se
->string_length
= len
;
2873 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2876 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
2878 tree gfc_int4_type_node
= gfc_get_int_type (4);
2887 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2888 len
= TREE_VALUE (args
);
2889 tmp
= gfc_advance_chain (args
, 2);
2890 ncopies
= TREE_VALUE (tmp
);
2891 len
= fold_build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
);
2892 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
2893 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
2895 arglist
= NULL_TREE
;
2896 arglist
= gfc_chainon_list (arglist
, var
);
2897 arglist
= chainon (arglist
, args
);
2898 tmp
= build_function_call_expr (gfor_fndecl_string_repeat
, arglist
);
2899 gfc_add_expr_to_block (&se
->pre
, tmp
);
2902 se
->string_length
= len
;
2906 /* Generate code for the IARGC intrinsic. */
2909 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
2915 /* Call the library function. This always returns an INTEGER(4). */
2916 fndecl
= gfor_fndecl_iargc
;
2917 tmp
= build_function_call_expr (fndecl
, NULL_TREE
);
2919 /* Convert it to the required type. */
2920 type
= gfc_typenode_for_spec (&expr
->ts
);
2921 tmp
= fold_convert (type
, tmp
);
2927 /* The loc intrinsic returns the address of its argument as
2928 gfc_index_integer_kind integer. */
2931 gfc_conv_intrinsic_loc(gfc_se
* se
, gfc_expr
* expr
)
2937 gcc_assert (!se
->ss
);
2939 arg_expr
= expr
->value
.function
.actual
->expr
;
2940 ss
= gfc_walk_expr (arg_expr
);
2941 if (ss
== gfc_ss_terminator
)
2942 gfc_conv_expr_reference (se
, arg_expr
);
2944 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1);
2945 se
->expr
= convert (gfc_unsigned_type (long_integer_type_node
),
2948 /* Create a temporary variable for loc return value. Without this,
2949 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
2950 temp_var
= gfc_create_var (gfc_unsigned_type (long_integer_type_node
),
2952 gfc_add_modify_expr (&se
->pre
, temp_var
, se
->expr
);
2953 se
->expr
= temp_var
;
2956 /* Generate code for an intrinsic function. Some map directly to library
2957 calls, others get special handling. In some cases the name of the function
2958 used depends on the type specifiers. */
2961 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
2963 gfc_intrinsic_sym
*isym
;
2967 isym
= expr
->value
.function
.isym
;
2969 name
= &expr
->value
.function
.name
[2];
2971 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
2973 lib
= gfc_is_intrinsic_libcall (expr
);
2977 se
->ignore_optional
= 1;
2978 gfc_conv_intrinsic_funcall (se
, expr
);
2983 switch (expr
->value
.function
.isym
->generic_id
)
2988 case GFC_ISYM_REPEAT
:
2989 gfc_conv_intrinsic_repeat (se
, expr
);
2993 gfc_conv_intrinsic_trim (se
, expr
);
2996 case GFC_ISYM_SI_KIND
:
2997 gfc_conv_intrinsic_si_kind (se
, expr
);
3000 case GFC_ISYM_SR_KIND
:
3001 gfc_conv_intrinsic_sr_kind (se
, expr
);
3004 case GFC_ISYM_EXPONENT
:
3005 gfc_conv_intrinsic_exponent (se
, expr
);
3008 case GFC_ISYM_SPACING
:
3009 gfc_conv_intrinsic_spacing (se
, expr
);
3012 case GFC_ISYM_RRSPACING
:
3013 gfc_conv_intrinsic_rrspacing (se
, expr
);
3017 gfc_conv_intrinsic_scan (se
, expr
);
3020 case GFC_ISYM_VERIFY
:
3021 gfc_conv_intrinsic_verify (se
, expr
);
3024 case GFC_ISYM_ALLOCATED
:
3025 gfc_conv_allocated (se
, expr
);
3028 case GFC_ISYM_ASSOCIATED
:
3029 gfc_conv_associated(se
, expr
);
3033 gfc_conv_intrinsic_abs (se
, expr
);
3036 case GFC_ISYM_ADJUSTL
:
3037 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
3040 case GFC_ISYM_ADJUSTR
:
3041 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
3044 case GFC_ISYM_AIMAG
:
3045 gfc_conv_intrinsic_imagpart (se
, expr
);
3049 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
3053 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
3056 case GFC_ISYM_ANINT
:
3057 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
3061 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3065 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
3068 case GFC_ISYM_BTEST
:
3069 gfc_conv_intrinsic_btest (se
, expr
);
3072 case GFC_ISYM_ACHAR
:
3074 gfc_conv_intrinsic_char (se
, expr
);
3077 case GFC_ISYM_CONVERSION
:
3079 case GFC_ISYM_LOGICAL
:
3081 gfc_conv_intrinsic_conversion (se
, expr
);
3084 /* Integer conversions are handled separately to make sure we get the
3085 correct rounding mode. */
3087 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
3091 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
3094 case GFC_ISYM_CEILING
:
3095 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
3098 case GFC_ISYM_FLOOR
:
3099 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
3103 gfc_conv_intrinsic_mod (se
, expr
, 0);
3106 case GFC_ISYM_MODULO
:
3107 gfc_conv_intrinsic_mod (se
, expr
, 1);
3110 case GFC_ISYM_CMPLX
:
3111 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
3114 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
3115 gfc_conv_intrinsic_iargc (se
, expr
);
3118 case GFC_ISYM_COMPLEX
:
3119 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
3122 case GFC_ISYM_CONJG
:
3123 gfc_conv_intrinsic_conjg (se
, expr
);
3126 case GFC_ISYM_COUNT
:
3127 gfc_conv_intrinsic_count (se
, expr
);
3130 case GFC_ISYM_CTIME
:
3131 gfc_conv_intrinsic_ctime (se
, expr
);
3135 gfc_conv_intrinsic_dim (se
, expr
);
3138 case GFC_ISYM_DPROD
:
3139 gfc_conv_intrinsic_dprod (se
, expr
);
3142 case GFC_ISYM_FDATE
:
3143 gfc_conv_intrinsic_fdate (se
, expr
);
3147 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3150 case GFC_ISYM_IBCLR
:
3151 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
3154 case GFC_ISYM_IBITS
:
3155 gfc_conv_intrinsic_ibits (se
, expr
);
3158 case GFC_ISYM_IBSET
:
3159 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
3162 case GFC_ISYM_IACHAR
:
3163 case GFC_ISYM_ICHAR
:
3164 /* We assume ASCII character sequence. */
3165 gfc_conv_intrinsic_ichar (se
, expr
);
3168 case GFC_ISYM_IARGC
:
3169 gfc_conv_intrinsic_iargc (se
, expr
);
3173 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3176 case GFC_ISYM_INDEX
:
3177 gfc_conv_intrinsic_index (se
, expr
);
3181 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3184 case GFC_ISYM_ISHFT
:
3185 gfc_conv_intrinsic_ishft (se
, expr
);
3188 case GFC_ISYM_ISHFTC
:
3189 gfc_conv_intrinsic_ishftc (se
, expr
);
3192 case GFC_ISYM_LBOUND
:
3193 gfc_conv_intrinsic_bound (se
, expr
, 0);
3196 case GFC_ISYM_TRANSPOSE
:
3197 if (se
->ss
&& se
->ss
->useflags
)
3199 gfc_conv_tmp_array_ref (se
);
3200 gfc_advance_se_ss_chain (se
);
3203 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
3207 gfc_conv_intrinsic_len (se
, expr
);
3210 case GFC_ISYM_LEN_TRIM
:
3211 gfc_conv_intrinsic_len_trim (se
, expr
);
3215 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
3219 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
3223 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
3227 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
3231 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
3234 case GFC_ISYM_MAXLOC
:
3235 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
3238 case GFC_ISYM_MAXVAL
:
3239 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
3242 case GFC_ISYM_MERGE
:
3243 gfc_conv_intrinsic_merge (se
, expr
);
3247 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
3250 case GFC_ISYM_MINLOC
:
3251 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
3254 case GFC_ISYM_MINVAL
:
3255 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
3259 gfc_conv_intrinsic_not (se
, expr
);
3263 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3266 case GFC_ISYM_PRESENT
:
3267 gfc_conv_intrinsic_present (se
, expr
);
3270 case GFC_ISYM_PRODUCT
:
3271 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
3275 gfc_conv_intrinsic_sign (se
, expr
);
3279 gfc_conv_intrinsic_size (se
, expr
);
3283 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
3286 case GFC_ISYM_TRANSFER
:
3287 gfc_conv_intrinsic_transfer (se
, expr
);
3290 case GFC_ISYM_TTYNAM
:
3291 gfc_conv_intrinsic_ttynam (se
, expr
);
3294 case GFC_ISYM_UBOUND
:
3295 gfc_conv_intrinsic_bound (se
, expr
, 1);
3299 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3303 gfc_conv_intrinsic_loc (se
, expr
);
3306 case GFC_ISYM_CHDIR
:
3307 case GFC_ISYM_DOT_PRODUCT
:
3308 case GFC_ISYM_ETIME
:
3310 case GFC_ISYM_FGETC
:
3313 case GFC_ISYM_FPUTC
:
3314 case GFC_ISYM_FSTAT
:
3315 case GFC_ISYM_FTELL
:
3316 case GFC_ISYM_GETCWD
:
3317 case GFC_ISYM_GETGID
:
3318 case GFC_ISYM_GETPID
:
3319 case GFC_ISYM_GETUID
:
3320 case GFC_ISYM_HOSTNM
:
3322 case GFC_ISYM_IERRNO
:
3323 case GFC_ISYM_IRAND
:
3324 case GFC_ISYM_ISATTY
:
3326 case GFC_ISYM_MALLOC
:
3327 case GFC_ISYM_MATMUL
:
3329 case GFC_ISYM_RENAME
:
3330 case GFC_ISYM_SECOND
:
3331 case GFC_ISYM_SECNDS
:
3332 case GFC_ISYM_SIGNAL
:
3334 case GFC_ISYM_SYMLNK
:
3335 case GFC_ISYM_SYSTEM
:
3337 case GFC_ISYM_TIME8
:
3338 case GFC_ISYM_UMASK
:
3339 case GFC_ISYM_UNLINK
:
3340 gfc_conv_intrinsic_funcall (se
, expr
);
3344 gfc_conv_intrinsic_lib_function (se
, expr
);
3350 /* This generates code to execute before entering the scalarization loop.
3351 Currently does nothing. */
3354 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3356 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3358 case GFC_ISYM_UBOUND
:
3359 case GFC_ISYM_LBOUND
:
3368 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3369 inside the scalarization loop. */
3372 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3376 /* The two argument version returns a scalar. */
3377 if (expr
->value
.function
.actual
->next
->expr
)
3380 newss
= gfc_get_ss ();
3381 newss
->type
= GFC_SS_INTRINSIC
;
3389 /* Walk an intrinsic array libcall. */
3392 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3396 gcc_assert (expr
->rank
> 0);
3398 newss
= gfc_get_ss ();
3399 newss
->type
= GFC_SS_FUNCTION
;
3402 newss
->data
.info
.dimen
= expr
->rank
;
3408 /* Returns nonzero if the specified intrinsic function call maps directly to a
3409 an external library call. Should only be used for functions that return
3413 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3415 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3416 gcc_assert (expr
->rank
> 0);
3418 switch (expr
->value
.function
.isym
->generic_id
)
3422 case GFC_ISYM_COUNT
:
3423 case GFC_ISYM_MATMUL
:
3424 case GFC_ISYM_MAXLOC
:
3425 case GFC_ISYM_MAXVAL
:
3426 case GFC_ISYM_MINLOC
:
3427 case GFC_ISYM_MINVAL
:
3428 case GFC_ISYM_PRODUCT
:
3430 case GFC_ISYM_SHAPE
:
3431 case GFC_ISYM_SPREAD
:
3432 case GFC_ISYM_TRANSPOSE
:
3433 /* Ignore absent optional parameters. */
3436 case GFC_ISYM_RESHAPE
:
3437 case GFC_ISYM_CSHIFT
:
3438 case GFC_ISYM_EOSHIFT
:
3440 case GFC_ISYM_UNPACK
:
3441 /* Pass absent optional parameters. */
3449 /* Walk an intrinsic function. */
3451 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3452 gfc_intrinsic_sym
* isym
)
3456 if (isym
->elemental
)
3457 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
3459 if (expr
->rank
== 0)
3462 if (gfc_is_intrinsic_libcall (expr
))
3463 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3465 /* Special cases. */
3466 switch (isym
->generic_id
)
3468 case GFC_ISYM_LBOUND
:
3469 case GFC_ISYM_UBOUND
:
3470 return gfc_walk_intrinsic_bound (ss
, expr
);
3473 /* This probably meant someone forgot to add an intrinsic to the above
3474 list(s) when they implemented it, or something's gone horribly wrong.
3476 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3477 expr
->value
.function
.name
);
3481 #include "gt-fortran-trans-intrinsic.h"