1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005 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
= gfc_build_function_call (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
= gfc_build_function_call (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
= gfc_build_function_call (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
= fold (gfc_build_function_call (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
= fold (gfc_build_function_call (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
;
1040 /* Get the minimum/maximum value of all the parameters.
1041 minmax (a1, a2, a3, ...)
1054 /* TODO: Mismatching types can occur when specific names are used.
1055 These should be handled during resolution. */
1057 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1068 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1069 type
= gfc_typenode_for_spec (&expr
->ts
);
1071 limit
= TREE_VALUE (arg
);
1072 if (TREE_TYPE (limit
) != type
)
1073 limit
= convert (type
, limit
);
1074 /* Only evaluate the argument once. */
1075 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1076 limit
= gfc_evaluate_now(limit
, &se
->pre
);
1078 mvar
= gfc_create_var (type
, "M");
1079 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1080 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1082 val
= TREE_VALUE (arg
);
1083 if (TREE_TYPE (val
) != type
)
1084 val
= convert (type
, val
);
1086 /* Only evaluate the argument once. */
1087 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1088 val
= gfc_evaluate_now(val
, &se
->pre
);
1090 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1092 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1093 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1094 gfc_add_expr_to_block (&se
->pre
, tmp
);
1095 elsecase
= build_empty_stmt ();
1102 /* Create a symbol node for this intrinsic. The symbol from the frontend
1103 has the generic name. */
1106 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1110 /* TODO: Add symbols for intrinsic function to the global namespace. */
1111 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1112 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1115 sym
->attr
.external
= 1;
1116 sym
->attr
.function
= 1;
1117 sym
->attr
.always_explicit
= 1;
1118 sym
->attr
.proc
= PROC_INTRINSIC
;
1119 sym
->attr
.flavor
= FL_PROCEDURE
;
1123 sym
->attr
.dimension
= 1;
1124 sym
->as
= gfc_get_array_spec ();
1125 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1126 sym
->as
->rank
= expr
->rank
;
1129 /* TODO: proper argument lists for external intrinsics. */
1133 /* Generate a call to an external intrinsic function. */
1135 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1139 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1142 gcc_assert (expr
->rank
> 0);
1144 gcc_assert (expr
->rank
== 0);
1146 sym
= gfc_get_symbol_for_expr (expr
);
1147 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1151 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1171 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1180 gfc_actual_arglist
*actual
;
1187 gfc_conv_intrinsic_funcall (se
, expr
);
1191 actual
= expr
->value
.function
.actual
;
1192 type
= gfc_typenode_for_spec (&expr
->ts
);
1193 /* Initialize the result. */
1194 resvar
= gfc_create_var (type
, "test");
1196 tmp
= convert (type
, boolean_true_node
);
1198 tmp
= convert (type
, boolean_false_node
);
1199 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1201 /* Walk the arguments. */
1202 arrayss
= gfc_walk_expr (actual
->expr
);
1203 gcc_assert (arrayss
!= gfc_ss_terminator
);
1205 /* Initialize the scalarizer. */
1206 gfc_init_loopinfo (&loop
);
1207 exit_label
= gfc_build_label_decl (NULL_TREE
);
1208 TREE_USED (exit_label
) = 1;
1209 gfc_add_ss_to_loop (&loop
, arrayss
);
1211 /* Initialize the loop. */
1212 gfc_conv_ss_startstride (&loop
);
1213 gfc_conv_loop_setup (&loop
);
1215 gfc_mark_ss_chain_used (arrayss
, 1);
1216 /* Generate the loop body. */
1217 gfc_start_scalarized_body (&loop
, &body
);
1219 /* If the condition matches then set the return value. */
1220 gfc_start_block (&block
);
1222 tmp
= convert (type
, boolean_false_node
);
1224 tmp
= convert (type
, boolean_true_node
);
1225 gfc_add_modify_expr (&block
, resvar
, tmp
);
1227 /* And break out of the loop. */
1228 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1229 gfc_add_expr_to_block (&block
, tmp
);
1231 found
= gfc_finish_block (&block
);
1233 /* Check this element. */
1234 gfc_init_se (&arrayse
, NULL
);
1235 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1236 arrayse
.ss
= arrayss
;
1237 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1239 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1240 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
,
1241 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1242 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1243 gfc_add_expr_to_block (&body
, tmp
);
1244 gfc_add_block_to_block (&body
, &arrayse
.post
);
1246 gfc_trans_scalarizing_loops (&loop
, &body
);
1248 /* Add the exit label. */
1249 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1250 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1252 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1253 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1254 gfc_cleanup_loop (&loop
);
1259 /* COUNT(A) = Number of true elements in A. */
1261 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1268 gfc_actual_arglist
*actual
;
1274 gfc_conv_intrinsic_funcall (se
, expr
);
1278 actual
= expr
->value
.function
.actual
;
1280 type
= gfc_typenode_for_spec (&expr
->ts
);
1281 /* Initialize the result. */
1282 resvar
= gfc_create_var (type
, "count");
1283 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1285 /* Walk the arguments. */
1286 arrayss
= gfc_walk_expr (actual
->expr
);
1287 gcc_assert (arrayss
!= gfc_ss_terminator
);
1289 /* Initialize the scalarizer. */
1290 gfc_init_loopinfo (&loop
);
1291 gfc_add_ss_to_loop (&loop
, arrayss
);
1293 /* Initialize the loop. */
1294 gfc_conv_ss_startstride (&loop
);
1295 gfc_conv_loop_setup (&loop
);
1297 gfc_mark_ss_chain_used (arrayss
, 1);
1298 /* Generate the loop body. */
1299 gfc_start_scalarized_body (&loop
, &body
);
1301 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1302 build_int_cst (TREE_TYPE (resvar
), 1));
1303 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1305 gfc_init_se (&arrayse
, NULL
);
1306 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1307 arrayse
.ss
= arrayss
;
1308 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1309 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1311 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1312 gfc_add_expr_to_block (&body
, tmp
);
1313 gfc_add_block_to_block (&body
, &arrayse
.post
);
1315 gfc_trans_scalarizing_loops (&loop
, &body
);
1317 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1318 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1319 gfc_cleanup_loop (&loop
);
1324 /* Inline implementation of the sum and product intrinsics. */
1326 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1334 gfc_actual_arglist
*actual
;
1339 gfc_expr
*arrayexpr
;
1344 gfc_conv_intrinsic_funcall (se
, expr
);
1348 type
= gfc_typenode_for_spec (&expr
->ts
);
1349 /* Initialize the result. */
1350 resvar
= gfc_create_var (type
, "val");
1351 if (op
== PLUS_EXPR
)
1352 tmp
= gfc_build_const (type
, integer_zero_node
);
1354 tmp
= gfc_build_const (type
, integer_one_node
);
1356 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1358 /* Walk the arguments. */
1359 actual
= expr
->value
.function
.actual
;
1360 arrayexpr
= actual
->expr
;
1361 arrayss
= gfc_walk_expr (arrayexpr
);
1362 gcc_assert (arrayss
!= gfc_ss_terminator
);
1364 actual
= actual
->next
->next
;
1365 gcc_assert (actual
);
1366 maskexpr
= actual
->expr
;
1369 maskss
= gfc_walk_expr (maskexpr
);
1370 gcc_assert (maskss
!= gfc_ss_terminator
);
1375 /* Initialize the scalarizer. */
1376 gfc_init_loopinfo (&loop
);
1377 gfc_add_ss_to_loop (&loop
, arrayss
);
1379 gfc_add_ss_to_loop (&loop
, maskss
);
1381 /* Initialize the loop. */
1382 gfc_conv_ss_startstride (&loop
);
1383 gfc_conv_loop_setup (&loop
);
1385 gfc_mark_ss_chain_used (arrayss
, 1);
1387 gfc_mark_ss_chain_used (maskss
, 1);
1388 /* Generate the loop body. */
1389 gfc_start_scalarized_body (&loop
, &body
);
1391 /* If we have a mask, only add this element if the mask is set. */
1394 gfc_init_se (&maskse
, NULL
);
1395 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1397 gfc_conv_expr_val (&maskse
, maskexpr
);
1398 gfc_add_block_to_block (&body
, &maskse
.pre
);
1400 gfc_start_block (&block
);
1403 gfc_init_block (&block
);
1405 /* Do the actual summation/product. */
1406 gfc_init_se (&arrayse
, NULL
);
1407 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1408 arrayse
.ss
= arrayss
;
1409 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1410 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1412 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1413 gfc_add_modify_expr (&block
, resvar
, tmp
);
1414 gfc_add_block_to_block (&block
, &arrayse
.post
);
1418 /* We enclose the above in if (mask) {...} . */
1419 tmp
= gfc_finish_block (&block
);
1421 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1424 tmp
= gfc_finish_block (&block
);
1425 gfc_add_expr_to_block (&body
, tmp
);
1427 gfc_trans_scalarizing_loops (&loop
, &body
);
1428 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1429 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1430 gfc_cleanup_loop (&loop
);
1436 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1440 stmtblock_t ifblock
;
1447 gfc_actual_arglist
*actual
;
1452 gfc_expr
*arrayexpr
;
1459 gfc_conv_intrinsic_funcall (se
, expr
);
1463 /* Initialize the result. */
1464 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1465 type
= gfc_typenode_for_spec (&expr
->ts
);
1467 /* Walk the arguments. */
1468 actual
= expr
->value
.function
.actual
;
1469 arrayexpr
= actual
->expr
;
1470 arrayss
= gfc_walk_expr (arrayexpr
);
1471 gcc_assert (arrayss
!= gfc_ss_terminator
);
1473 actual
= actual
->next
->next
;
1474 gcc_assert (actual
);
1475 maskexpr
= actual
->expr
;
1478 maskss
= gfc_walk_expr (maskexpr
);
1479 gcc_assert (maskss
!= gfc_ss_terminator
);
1484 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1485 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1486 switch (arrayexpr
->ts
.type
)
1489 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1493 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1494 arrayexpr
->ts
.kind
);
1501 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1503 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1504 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1506 /* Initialize the scalarizer. */
1507 gfc_init_loopinfo (&loop
);
1508 gfc_add_ss_to_loop (&loop
, arrayss
);
1510 gfc_add_ss_to_loop (&loop
, maskss
);
1512 /* Initialize the loop. */
1513 gfc_conv_ss_startstride (&loop
);
1514 gfc_conv_loop_setup (&loop
);
1516 gcc_assert (loop
.dimen
== 1);
1518 /* Initialize the position to the first element. If the array has zero
1519 size we need to return zero. Otherwise use the first element of the
1520 array, in case all elements are equal to the limit.
1521 i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1522 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1523 loop
.from
[0], gfc_index_one_node
);
1524 cond
= fold_build2 (GE_EXPR
, boolean_type_node
,
1525 loop
.to
[0], loop
.from
[0]);
1526 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1528 gfc_add_modify_expr (&loop
.pre
, pos
, tmp
);
1530 gfc_mark_ss_chain_used (arrayss
, 1);
1532 gfc_mark_ss_chain_used (maskss
, 1);
1533 /* Generate the loop body. */
1534 gfc_start_scalarized_body (&loop
, &body
);
1536 /* If we have a mask, only check this element if the mask is set. */
1539 gfc_init_se (&maskse
, NULL
);
1540 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1542 gfc_conv_expr_val (&maskse
, maskexpr
);
1543 gfc_add_block_to_block (&body
, &maskse
.pre
);
1545 gfc_start_block (&block
);
1548 gfc_init_block (&block
);
1550 /* Compare with the current limit. */
1551 gfc_init_se (&arrayse
, NULL
);
1552 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1553 arrayse
.ss
= arrayss
;
1554 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1555 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1557 /* We do the following if this is a more extreme value. */
1558 gfc_start_block (&ifblock
);
1560 /* Assign the value to the limit... */
1561 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
1563 /* Remember where we are. */
1564 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
1566 ifbody
= gfc_finish_block (&ifblock
);
1568 /* If it is a more extreme value. */
1569 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1570 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1571 gfc_add_expr_to_block (&block
, tmp
);
1575 /* We enclose the above in if (mask) {...}. */
1576 tmp
= gfc_finish_block (&block
);
1578 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1581 tmp
= gfc_finish_block (&block
);
1582 gfc_add_expr_to_block (&body
, tmp
);
1584 gfc_trans_scalarizing_loops (&loop
, &body
);
1586 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1587 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1588 gfc_cleanup_loop (&loop
);
1590 /* Return a value in the range 1..SIZE(array). */
1591 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
1592 gfc_index_one_node
);
1593 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
);
1594 /* And convert to the required type. */
1595 se
->expr
= convert (type
, tmp
);
1599 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
1608 gfc_actual_arglist
*actual
;
1613 gfc_expr
*arrayexpr
;
1619 gfc_conv_intrinsic_funcall (se
, expr
);
1623 type
= gfc_typenode_for_spec (&expr
->ts
);
1624 /* Initialize the result. */
1625 limit
= gfc_create_var (type
, "limit");
1626 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
1627 switch (expr
->ts
.type
)
1630 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
1634 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
1641 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1643 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1644 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1646 /* Walk the arguments. */
1647 actual
= expr
->value
.function
.actual
;
1648 arrayexpr
= actual
->expr
;
1649 arrayss
= gfc_walk_expr (arrayexpr
);
1650 gcc_assert (arrayss
!= gfc_ss_terminator
);
1652 actual
= actual
->next
->next
;
1653 gcc_assert (actual
);
1654 maskexpr
= actual
->expr
;
1657 maskss
= gfc_walk_expr (maskexpr
);
1658 gcc_assert (maskss
!= gfc_ss_terminator
);
1663 /* Initialize the scalarizer. */
1664 gfc_init_loopinfo (&loop
);
1665 gfc_add_ss_to_loop (&loop
, arrayss
);
1667 gfc_add_ss_to_loop (&loop
, maskss
);
1669 /* Initialize the loop. */
1670 gfc_conv_ss_startstride (&loop
);
1671 gfc_conv_loop_setup (&loop
);
1673 gfc_mark_ss_chain_used (arrayss
, 1);
1675 gfc_mark_ss_chain_used (maskss
, 1);
1676 /* Generate the loop body. */
1677 gfc_start_scalarized_body (&loop
, &body
);
1679 /* If we have a mask, only add this element if the mask is set. */
1682 gfc_init_se (&maskse
, NULL
);
1683 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1685 gfc_conv_expr_val (&maskse
, maskexpr
);
1686 gfc_add_block_to_block (&body
, &maskse
.pre
);
1688 gfc_start_block (&block
);
1691 gfc_init_block (&block
);
1693 /* Compare with the current limit. */
1694 gfc_init_se (&arrayse
, NULL
);
1695 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1696 arrayse
.ss
= arrayss
;
1697 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1698 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1700 /* Assign the value to the limit... */
1701 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
1703 /* If it is a more extreme value. */
1704 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1705 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1706 gfc_add_expr_to_block (&block
, tmp
);
1707 gfc_add_block_to_block (&block
, &arrayse
.post
);
1709 tmp
= gfc_finish_block (&block
);
1711 /* We enclose the above in if (mask) {...}. */
1712 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1713 gfc_add_expr_to_block (&body
, tmp
);
1715 gfc_trans_scalarizing_loops (&loop
, &body
);
1717 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1718 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1719 gfc_cleanup_loop (&loop
);
1724 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1726 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
1733 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1734 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1735 arg
= TREE_VALUE (arg
);
1736 type
= TREE_TYPE (arg
);
1738 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1739 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
1740 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
1741 build_int_cst (type
, 0));
1742 type
= gfc_typenode_for_spec (&expr
->ts
);
1743 se
->expr
= convert (type
, tmp
);
1746 /* Generate code to perform the specified operation. */
1748 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
1754 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1755 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1756 arg
= TREE_VALUE (arg
);
1757 type
= TREE_TYPE (arg
);
1759 se
->expr
= fold_build2 (op
, type
, arg
, arg2
);
1764 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
1768 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1769 arg
= TREE_VALUE (arg
);
1771 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
1774 /* Set or clear a single bit. */
1776 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
1784 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1785 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1786 arg
= TREE_VALUE (arg
);
1787 type
= TREE_TYPE (arg
);
1789 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1795 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
1797 se
->expr
= fold_build2 (op
, type
, arg
, tmp
);
1800 /* Extract a sequence of bits.
1801 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1803 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
1812 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1813 arg2
= TREE_CHAIN (arg
);
1814 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
1815 arg
= TREE_VALUE (arg
);
1816 arg2
= TREE_VALUE (arg2
);
1817 type
= TREE_TYPE (arg
);
1819 mask
= build_int_cst (NULL_TREE
, -1);
1820 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
1821 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
1823 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
1825 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
1828 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1830 : ((shift >= 0) ? i << shift : i >> -shift)
1831 where all shifts are logical shifts. */
1833 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
1846 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1847 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1848 arg
= TREE_VALUE (arg
);
1849 type
= TREE_TYPE (arg
);
1850 utype
= gfc_unsigned_type (type
);
1852 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
);
1854 /* Left shift if positive. */
1855 lshift
= fold_build2 (LSHIFT_EXPR
, type
, arg
, width
);
1857 /* Right shift if negative.
1858 We convert to an unsigned type because we want a logical shift.
1859 The standard doesn't define the case of shifting negative
1860 numbers, and we try to be compatible with other compilers, most
1861 notably g77, here. */
1862 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
1863 convert (utype
, arg
), width
));
1865 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
,
1866 build_int_cst (TREE_TYPE (arg2
), 0));
1867 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
1869 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1870 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1872 num_bits
= build_int_cst (TREE_TYPE (arg2
), TYPE_PRECISION (type
));
1873 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
1875 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
1876 build_int_cst (type
, 0), tmp
);
1879 /* Circular shift. AKA rotate or barrel shift. */
1881 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
1892 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1893 arg2
= TREE_CHAIN (arg
);
1894 arg3
= TREE_CHAIN (arg2
);
1897 /* Use a library function for the 3 parameter version. */
1898 tree int4type
= gfc_get_int_type (4);
1900 type
= TREE_TYPE (TREE_VALUE (arg
));
1901 /* We convert the first argument to at least 4 bytes, and
1902 convert back afterwards. This removes the need for library
1903 functions for all argument sizes, and function will be
1904 aligned to at least 32 bits, so there's no loss. */
1905 if (expr
->ts
.kind
< 4)
1907 tmp
= convert (int4type
, TREE_VALUE (arg
));
1908 TREE_VALUE (arg
) = tmp
;
1910 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1911 need loads of library functions. They cannot have values >
1912 BIT_SIZE (I) so the conversion is safe. */
1913 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
1914 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
1916 switch (expr
->ts
.kind
)
1921 tmp
= gfor_fndecl_math_ishftc4
;
1924 tmp
= gfor_fndecl_math_ishftc8
;
1927 tmp
= gfor_fndecl_math_ishftc16
;
1932 se
->expr
= gfc_build_function_call (tmp
, arg
);
1933 /* Convert the result back to the original type, if we extended
1934 the first argument's width above. */
1935 if (expr
->ts
.kind
< 4)
1936 se
->expr
= convert (type
, se
->expr
);
1940 arg
= TREE_VALUE (arg
);
1941 arg2
= TREE_VALUE (arg2
);
1942 type
= TREE_TYPE (arg
);
1944 /* Rotate left if positive. */
1945 lrot
= fold_build2 (LROTATE_EXPR
, type
, arg
, arg2
);
1947 /* Rotate right if negative. */
1948 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
1949 rrot
= fold_build2 (RROTATE_EXPR
, type
, arg
, tmp
);
1951 zero
= build_int_cst (TREE_TYPE (arg2
), 0);
1952 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
);
1953 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
1955 /* Do nothing if shift == 0. */
1956 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg2
, zero
);
1957 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, arg
, rrot
);
1960 /* The length of a character string. */
1962 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
1971 gcc_assert (!se
->ss
);
1973 arg
= expr
->value
.function
.actual
->expr
;
1975 type
= gfc_typenode_for_spec (&expr
->ts
);
1976 switch (arg
->expr_type
)
1979 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
1983 if (arg
->expr_type
== EXPR_VARIABLE
1984 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
1985 && arg
->ref
->type
== REF_ARRAY
)))
1987 /* This doesn't catch all cases.
1988 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1989 and the surrounding thread. */
1990 sym
= arg
->symtree
->n
.sym
;
1991 decl
= gfc_get_symbol_decl (sym
);
1992 if (decl
== current_function_decl
&& sym
->attr
.function
1993 && (sym
->result
== sym
))
1994 decl
= gfc_get_fake_result_decl (sym
);
1996 len
= sym
->ts
.cl
->backend_decl
;
2001 /* Anybody stupid enough to do this deserves inefficient code. */
2002 gfc_init_se (&argse
, se
);
2003 gfc_conv_expr (&argse
, arg
);
2004 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2005 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2006 len
= argse
.string_length
;
2010 se
->expr
= convert (type
, len
);
2013 /* The length of a character string not including trailing blanks. */
2015 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2020 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2021 type
= gfc_typenode_for_spec (&expr
->ts
);
2022 se
->expr
= gfc_build_function_call (gfor_fndecl_string_len_trim
, args
);
2023 se
->expr
= convert (type
, se
->expr
);
2027 /* Returns the starting position of a substring within a string. */
2030 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
2032 tree logical4_type_node
= gfc_get_logical_type (4);
2038 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2039 type
= gfc_typenode_for_spec (&expr
->ts
);
2040 tmp
= gfc_advance_chain (args
, 3);
2041 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2043 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2045 TREE_CHAIN (tmp
) = back
;
2049 back
= TREE_CHAIN (tmp
);
2050 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2053 se
->expr
= gfc_build_function_call (gfor_fndecl_string_index
, args
);
2054 se
->expr
= convert (type
, se
->expr
);
2057 /* The ascii value for a single character. */
2059 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2064 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2065 arg
= TREE_VALUE (TREE_CHAIN (arg
));
2066 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
2067 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
2068 type
= gfc_typenode_for_spec (&expr
->ts
);
2070 se
->expr
= gfc_build_indirect_ref (arg
);
2071 se
->expr
= convert (type
, se
->expr
);
2075 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2078 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2087 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2088 if (expr
->ts
.type
!= BT_CHARACTER
)
2090 tsource
= TREE_VALUE (arg
);
2091 arg
= TREE_CHAIN (arg
);
2092 fsource
= TREE_VALUE (arg
);
2093 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2097 /* We do the same as in the non-character case, but the argument
2098 list is different because of the string length arguments. We
2099 also have to set the string length for the result. */
2100 len
= TREE_VALUE (arg
);
2101 arg
= TREE_CHAIN (arg
);
2102 tsource
= TREE_VALUE (arg
);
2103 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2104 fsource
= TREE_VALUE (arg
);
2105 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2107 se
->string_length
= len
;
2109 type
= TREE_TYPE (tsource
);
2110 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2115 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2117 gfc_actual_arglist
*actual
;
2124 gfc_init_se (&argse
, NULL
);
2125 actual
= expr
->value
.function
.actual
;
2127 ss
= gfc_walk_expr (actual
->expr
);
2128 gcc_assert (ss
!= gfc_ss_terminator
);
2129 argse
.want_pointer
= 1;
2130 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2131 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2132 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2133 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2135 actual
= actual
->next
;
2138 gfc_init_se (&argse
, NULL
);
2139 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2140 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2141 args
= gfc_chainon_list (args
, argse
.expr
);
2142 fndecl
= gfor_fndecl_size1
;
2145 fndecl
= gfor_fndecl_size0
;
2147 se
->expr
= gfc_build_function_call (fndecl
, args
);
2148 type
= gfc_typenode_for_spec (&expr
->ts
);
2149 se
->expr
= convert (type
, se
->expr
);
2153 /* Intrinsic string comparison functions. */
2156 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2161 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2162 /* Build a call for the comparison. */
2163 se
->expr
= gfc_build_function_call (gfor_fndecl_compare_string
, args
);
2165 type
= gfc_typenode_for_spec (&expr
->ts
);
2166 se
->expr
= build2 (op
, type
, se
->expr
,
2167 build_int_cst (TREE_TYPE (se
->expr
), 0));
2170 /* Generate a call to the adjustl/adjustr library function. */
2172 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2180 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2181 len
= TREE_VALUE (args
);
2183 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2184 var
= gfc_conv_string_tmp (se
, type
, len
);
2185 args
= tree_cons (NULL_TREE
, var
, args
);
2187 tmp
= gfc_build_function_call (fndecl
, args
);
2188 gfc_add_expr_to_block (&se
->pre
, tmp
);
2190 se
->string_length
= len
;
2194 /* Scalar transfer statement.
2195 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2198 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2200 gfc_actual_arglist
*arg
;
2206 gcc_assert (!se
->ss
);
2208 /* Get a pointer to the source. */
2209 arg
= expr
->value
.function
.actual
;
2210 ss
= gfc_walk_expr (arg
->expr
);
2211 gfc_init_se (&argse
, NULL
);
2212 if (ss
== gfc_ss_terminator
)
2213 gfc_conv_expr_reference (&argse
, arg
->expr
);
2215 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2216 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2217 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2221 type
= gfc_typenode_for_spec (&expr
->ts
);
2222 ptr
= convert (build_pointer_type (type
), ptr
);
2223 if (expr
->ts
.type
== BT_CHARACTER
)
2225 gfc_init_se (&argse
, NULL
);
2226 gfc_conv_expr (&argse
, arg
->expr
);
2227 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2228 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2230 se
->string_length
= argse
.string_length
;
2234 se
->expr
= gfc_build_indirect_ref (ptr
);
2239 /* Generate code for the ALLOCATED intrinsic.
2240 Generate inline code that directly check the address of the argument. */
2243 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2245 gfc_actual_arglist
*arg1
;
2250 gfc_init_se (&arg1se
, NULL
);
2251 arg1
= expr
->value
.function
.actual
;
2252 ss1
= gfc_walk_expr (arg1
->expr
);
2253 arg1se
.descriptor_only
= 1;
2254 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2256 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
2257 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2258 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2259 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2263 /* Generate code for the ASSOCIATED intrinsic.
2264 If both POINTER and TARGET are arrays, generate a call to library function
2265 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2266 In other cases, generate inline code that directly compare the address of
2267 POINTER with the address of TARGET. */
2270 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2272 gfc_actual_arglist
*arg1
;
2273 gfc_actual_arglist
*arg2
;
2281 gfc_init_se (&arg1se
, NULL
);
2282 gfc_init_se (&arg2se
, NULL
);
2283 arg1
= expr
->value
.function
.actual
;
2285 ss1
= gfc_walk_expr (arg1
->expr
);
2289 /* No optional target. */
2290 if (ss1
== gfc_ss_terminator
)
2292 /* A pointer to a scalar. */
2293 arg1se
.want_pointer
= 1;
2294 gfc_conv_expr (&arg1se
, arg1
->expr
);
2299 /* A pointer to an array. */
2300 arg1se
.descriptor_only
= 1;
2301 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2302 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
2304 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2305 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2310 /* An optional target. */
2311 ss2
= gfc_walk_expr (arg2
->expr
);
2312 if (ss1
== gfc_ss_terminator
)
2314 /* A pointer to a scalar. */
2315 gcc_assert (ss2
== gfc_ss_terminator
);
2316 arg1se
.want_pointer
= 1;
2317 gfc_conv_expr (&arg1se
, arg1
->expr
);
2318 arg2se
.want_pointer
= 1;
2319 gfc_conv_expr (&arg2se
, arg2
->expr
);
2320 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2325 /* A pointer to an array, call library function _gfor_associated. */
2326 gcc_assert (ss2
!= gfc_ss_terminator
);
2328 arg1se
.want_pointer
= 1;
2329 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2330 args
= gfc_chainon_list (args
, arg1se
.expr
);
2331 arg2se
.want_pointer
= 1;
2332 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2333 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2334 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2335 args
= gfc_chainon_list (args
, arg2se
.expr
);
2336 fndecl
= gfor_fndecl_associated
;
2337 se
->expr
= gfc_build_function_call (fndecl
, args
);
2340 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2344 /* Scan a string for any one of the characters in a set of characters. */
2347 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2349 tree logical4_type_node
= gfc_get_logical_type (4);
2355 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2356 type
= gfc_typenode_for_spec (&expr
->ts
);
2357 tmp
= gfc_advance_chain (args
, 3);
2358 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2360 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2362 TREE_CHAIN (tmp
) = back
;
2366 back
= TREE_CHAIN (tmp
);
2367 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2370 se
->expr
= gfc_build_function_call (gfor_fndecl_string_scan
, args
);
2371 se
->expr
= convert (type
, se
->expr
);
2375 /* Verify that a set of characters contains all the characters in a string
2376 by identifying the position of the first character in a string of
2377 characters that does not appear in a given set of characters. */
2380 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2382 tree logical4_type_node
= gfc_get_logical_type (4);
2388 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2389 type
= gfc_typenode_for_spec (&expr
->ts
);
2390 tmp
= gfc_advance_chain (args
, 3);
2391 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2393 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2395 TREE_CHAIN (tmp
) = back
;
2399 back
= TREE_CHAIN (tmp
);
2400 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2403 se
->expr
= gfc_build_function_call (gfor_fndecl_string_verify
, args
);
2404 se
->expr
= convert (type
, se
->expr
);
2407 /* Prepare components and related information of a real number which is
2408 the first argument of a elemental functions to manipulate reals. */
2411 prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2412 real_compnt_info
* rcs
, int all
)
2419 tree exponent
, fraction
;
2423 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2424 gfc_todo_error ("Non-IEEE floating format");
2426 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2428 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2429 arg
= TREE_VALUE (arg
);
2430 rcs
->type
= TREE_TYPE (arg
);
2432 /* Force arg'type to integer by unaffected convert */
2433 a1
= expr
->value
.function
.actual
->expr
;
2434 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2435 rcs
->mtype
= masktype
;
2436 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2437 arg
= gfc_create_var (masktype
, "arg");
2438 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2441 /* Calculate the numbers of bits of exponent, fraction and word */
2442 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2443 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2444 rcs
->fdigits
= convert (masktype
, tmp
);
2445 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2446 wbits
= convert (masktype
, wbits
);
2447 rcs
->edigits
= fold_build2 (MINUS_EXPR
, masktype
, wbits
, tmp
);
2449 /* Form masks for exponent/fraction/sign */
2450 one
= gfc_build_const (masktype
, integer_one_node
);
2451 rcs
->smask
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, wbits
);
2452 rcs
->f1
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
);
2453 rcs
->emask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
);
2454 rcs
->fmask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
);
2456 tmp
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
);
2457 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, tmp
);
2458 rcs
->bias
= fold_build2 (MINUS_EXPR
, masktype
, tmp
,one
);
2462 /* exponent, and fraction */
2463 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2464 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2465 exponent
= gfc_create_var (masktype
, "exponent");
2466 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2467 rcs
->expn
= exponent
;
2469 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2470 fraction
= gfc_create_var (masktype
, "fraction");
2471 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2472 rcs
->frac
= fraction
;
2476 /* Build a call to __builtin_clz. */
2479 call_builtin_clz (tree result_type
, tree op0
)
2481 tree fn
, parms
, call
;
2482 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2484 if (op0_mode
== TYPE_MODE (integer_type_node
))
2485 fn
= built_in_decls
[BUILT_IN_CLZ
];
2486 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2487 fn
= built_in_decls
[BUILT_IN_CLZL
];
2488 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2489 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2493 parms
= tree_cons (NULL
, op0
, NULL
);
2494 call
= gfc_build_function_call (fn
, parms
);
2496 return convert (result_type
, call
);
2500 /* Generate code for SPACING (X) intrinsic function.
2501 SPACING (X) = POW (2, e-p)
2505 t = expn - fdigits // e - p.
2506 res = t << fdigits // Form the exponent. Fraction is zero.
2507 if (t < 0) // The result is out of range. Denormalized case.
2512 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2519 real_compnt_info rcs
;
2521 prepare_arg_info (se
, expr
, &rcs
, 0);
2523 masktype
= rcs
.mtype
;
2524 fdigits
= rcs
.fdigits
;
2526 zero
= gfc_build_const (masktype
, integer_zero_node
);
2527 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
2528 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2529 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
2530 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
2531 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2532 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
2533 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2538 /* Generate code for RRSPACING (X) intrinsic function.
2539 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2541 So the result's exponent is p. And if X is normalized, X's fraction part
2542 is the result's fraction. If X is denormalized, to get the X's fraction we
2543 shift X's fraction part to left until the first '1' is removed.
2547 if (expn == 0 && frac == 0)
2551 // edigits is the number of exponent bits. Add the sign bit.
2552 sedigits = edigits + 1;
2554 if (expn == 0) // Denormalized case.
2556 t1 = leadzero (frac);
2557 frac = frac << (t1 + 1); //Remove the first '1'.
2558 frac = frac >> (sedigits); //Form the fraction.
2561 //fdigits is the number of fraction bits. Form the exponent.
2564 res = (t << fdigits) | frac;
2569 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
2572 tree tmp
, t1
, t2
, cond
, cond2
;
2574 tree fdigits
, fraction
;
2575 real_compnt_info rcs
;
2577 prepare_arg_info (se
, expr
, &rcs
, 1);
2578 masktype
= rcs
.mtype
;
2579 fdigits
= rcs
.fdigits
;
2580 fraction
= rcs
.frac
;
2581 one
= gfc_build_const (masktype
, integer_one_node
);
2582 zero
= gfc_build_const (masktype
, integer_zero_node
);
2583 t2
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
);
2585 t1
= call_builtin_clz (masktype
, fraction
);
2586 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
2587 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
2588 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
2589 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
2590 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
2592 tmp
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
);
2593 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2594 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
2596 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
2597 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
2598 tmp
= build3 (COND_EXPR
, masktype
, cond
,
2599 build_int_cst (masktype
, 0), tmp
);
2601 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2605 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2608 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
2612 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2613 args
= TREE_VALUE (args
);
2614 args
= gfc_build_addr_expr (NULL
, args
);
2615 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
2616 se
->expr
= gfc_build_function_call (gfor_fndecl_si_kind
, args
);
2619 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2622 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
2624 gfc_actual_arglist
*actual
;
2629 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2631 gfc_init_se (&argse
, se
);
2633 /* Pass a NULL pointer for an absent arg. */
2634 if (actual
->expr
== NULL
)
2635 argse
.expr
= null_pointer_node
;
2637 gfc_conv_expr_reference (&argse
, actual
->expr
);
2639 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2640 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2641 args
= gfc_chainon_list (args
, argse
.expr
);
2643 se
->expr
= gfc_build_function_call (gfor_fndecl_sr_kind
, args
);
2647 /* Generate code for TRIM (A) intrinsic function. */
2650 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
2652 tree gfc_int4_type_node
= gfc_get_int_type (4);
2661 arglist
= NULL_TREE
;
2663 type
= build_pointer_type (gfc_character1_type_node
);
2664 var
= gfc_create_var (type
, "pstr");
2665 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
2666 len
= gfc_create_var (gfc_int4_type_node
, "len");
2668 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
2669 arglist
= gfc_chainon_list (arglist
, gfc_build_addr_expr (NULL
, len
));
2670 arglist
= gfc_chainon_list (arglist
, addr
);
2671 arglist
= chainon (arglist
, tmp
);
2673 tmp
= gfc_build_function_call (gfor_fndecl_string_trim
, arglist
);
2674 gfc_add_expr_to_block (&se
->pre
, tmp
);
2676 /* Free the temporary afterwards, if necessary. */
2677 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
2678 build_int_cst (TREE_TYPE (len
), 0));
2679 arglist
= gfc_chainon_list (NULL_TREE
, var
);
2680 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, arglist
);
2681 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2682 gfc_add_expr_to_block (&se
->post
, tmp
);
2685 se
->string_length
= len
;
2689 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2692 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
2694 tree gfc_int4_type_node
= gfc_get_int_type (4);
2703 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2704 len
= TREE_VALUE (args
);
2705 tmp
= gfc_advance_chain (args
, 2);
2706 ncopies
= TREE_VALUE (tmp
);
2707 len
= fold_build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
);
2708 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
2709 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
2711 arglist
= NULL_TREE
;
2712 arglist
= gfc_chainon_list (arglist
, var
);
2713 arglist
= chainon (arglist
, args
);
2714 tmp
= gfc_build_function_call (gfor_fndecl_string_repeat
, arglist
);
2715 gfc_add_expr_to_block (&se
->pre
, tmp
);
2718 se
->string_length
= len
;
2722 /* Generate code for the IARGC intrinsic. */
2725 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
2731 /* Call the library function. This always returns an INTEGER(4). */
2732 fndecl
= gfor_fndecl_iargc
;
2733 tmp
= gfc_build_function_call (fndecl
, NULL_TREE
);
2735 /* Convert it to the required type. */
2736 type
= gfc_typenode_for_spec (&expr
->ts
);
2737 tmp
= fold_convert (type
, tmp
);
2742 /* Generate code for an intrinsic function. Some map directly to library
2743 calls, others get special handling. In some cases the name of the function
2744 used depends on the type specifiers. */
2747 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
2749 gfc_intrinsic_sym
*isym
;
2753 isym
= expr
->value
.function
.isym
;
2755 name
= &expr
->value
.function
.name
[2];
2759 lib
= gfc_is_intrinsic_libcall (expr
);
2763 se
->ignore_optional
= 1;
2764 gfc_conv_intrinsic_funcall (se
, expr
);
2769 switch (expr
->value
.function
.isym
->generic_id
)
2774 case GFC_ISYM_REPEAT
:
2775 gfc_conv_intrinsic_repeat (se
, expr
);
2779 gfc_conv_intrinsic_trim (se
, expr
);
2782 case GFC_ISYM_SI_KIND
:
2783 gfc_conv_intrinsic_si_kind (se
, expr
);
2786 case GFC_ISYM_SR_KIND
:
2787 gfc_conv_intrinsic_sr_kind (se
, expr
);
2790 case GFC_ISYM_EXPONENT
:
2791 gfc_conv_intrinsic_exponent (se
, expr
);
2794 case GFC_ISYM_SPACING
:
2795 gfc_conv_intrinsic_spacing (se
, expr
);
2798 case GFC_ISYM_RRSPACING
:
2799 gfc_conv_intrinsic_rrspacing (se
, expr
);
2803 gfc_conv_intrinsic_scan (se
, expr
);
2806 case GFC_ISYM_VERIFY
:
2807 gfc_conv_intrinsic_verify (se
, expr
);
2810 case GFC_ISYM_ALLOCATED
:
2811 gfc_conv_allocated (se
, expr
);
2814 case GFC_ISYM_ASSOCIATED
:
2815 gfc_conv_associated(se
, expr
);
2819 gfc_conv_intrinsic_abs (se
, expr
);
2822 case GFC_ISYM_ADJUSTL
:
2823 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
2826 case GFC_ISYM_ADJUSTR
:
2827 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
2830 case GFC_ISYM_AIMAG
:
2831 gfc_conv_intrinsic_imagpart (se
, expr
);
2835 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
2839 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
2842 case GFC_ISYM_ANINT
:
2843 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
2847 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
2850 case GFC_ISYM_BTEST
:
2851 gfc_conv_intrinsic_btest (se
, expr
);
2854 case GFC_ISYM_ACHAR
:
2856 gfc_conv_intrinsic_char (se
, expr
);
2859 case GFC_ISYM_CONVERSION
:
2861 case GFC_ISYM_LOGICAL
:
2863 gfc_conv_intrinsic_conversion (se
, expr
);
2866 /* Integer conversions are handled separately to make sure we get the
2867 correct rounding mode. */
2869 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
2873 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
2876 case GFC_ISYM_CEILING
:
2877 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
2880 case GFC_ISYM_FLOOR
:
2881 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
2885 gfc_conv_intrinsic_mod (se
, expr
, 0);
2888 case GFC_ISYM_MODULO
:
2889 gfc_conv_intrinsic_mod (se
, expr
, 1);
2892 case GFC_ISYM_CMPLX
:
2893 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
2896 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
2897 gfc_conv_intrinsic_iargc (se
, expr
);
2900 case GFC_ISYM_CONJG
:
2901 gfc_conv_intrinsic_conjg (se
, expr
);
2904 case GFC_ISYM_COUNT
:
2905 gfc_conv_intrinsic_count (se
, expr
);
2909 gfc_conv_intrinsic_dim (se
, expr
);
2912 case GFC_ISYM_DPROD
:
2913 gfc_conv_intrinsic_dprod (se
, expr
);
2917 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
2920 case GFC_ISYM_IBCLR
:
2921 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
2924 case GFC_ISYM_IBITS
:
2925 gfc_conv_intrinsic_ibits (se
, expr
);
2928 case GFC_ISYM_IBSET
:
2929 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
2932 case GFC_ISYM_IACHAR
:
2933 case GFC_ISYM_ICHAR
:
2934 /* We assume ASCII character sequence. */
2935 gfc_conv_intrinsic_ichar (se
, expr
);
2938 case GFC_ISYM_IARGC
:
2939 gfc_conv_intrinsic_iargc (se
, expr
);
2943 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
2946 case GFC_ISYM_INDEX
:
2947 gfc_conv_intrinsic_index (se
, expr
);
2951 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
2954 case GFC_ISYM_ISHFT
:
2955 gfc_conv_intrinsic_ishft (se
, expr
);
2958 case GFC_ISYM_ISHFTC
:
2959 gfc_conv_intrinsic_ishftc (se
, expr
);
2962 case GFC_ISYM_LBOUND
:
2963 gfc_conv_intrinsic_bound (se
, expr
, 0);
2967 gfc_conv_intrinsic_len (se
, expr
);
2970 case GFC_ISYM_LEN_TRIM
:
2971 gfc_conv_intrinsic_len_trim (se
, expr
);
2975 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
2979 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
2983 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
2987 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
2991 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
2994 case GFC_ISYM_MAXLOC
:
2995 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
2998 case GFC_ISYM_MAXVAL
:
2999 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
3002 case GFC_ISYM_MERGE
:
3003 gfc_conv_intrinsic_merge (se
, expr
);
3007 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
3010 case GFC_ISYM_MINLOC
:
3011 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
3014 case GFC_ISYM_MINVAL
:
3015 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
3019 gfc_conv_intrinsic_not (se
, expr
);
3022 case GFC_ISYM_PRESENT
:
3023 gfc_conv_intrinsic_present (se
, expr
);
3026 case GFC_ISYM_PRODUCT
:
3027 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
3031 gfc_conv_intrinsic_sign (se
, expr
);
3035 gfc_conv_intrinsic_size (se
, expr
);
3039 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
3042 case GFC_ISYM_TRANSFER
:
3043 gfc_conv_intrinsic_transfer (se
, expr
);
3046 case GFC_ISYM_UBOUND
:
3047 gfc_conv_intrinsic_bound (se
, expr
, 1);
3050 case GFC_ISYM_CHDIR
:
3051 case GFC_ISYM_DOT_PRODUCT
:
3052 case GFC_ISYM_ETIME
:
3054 case GFC_ISYM_FSTAT
:
3055 case GFC_ISYM_GETCWD
:
3056 case GFC_ISYM_GETGID
:
3057 case GFC_ISYM_GETPID
:
3058 case GFC_ISYM_GETUID
:
3059 case GFC_ISYM_HOSTNM
:
3061 case GFC_ISYM_IERRNO
:
3062 case GFC_ISYM_IRAND
:
3063 case GFC_ISYM_ISATTY
:
3065 case GFC_ISYM_MATMUL
:
3067 case GFC_ISYM_RENAME
:
3068 case GFC_ISYM_SECOND
:
3070 case GFC_ISYM_SYMLNK
:
3071 case GFC_ISYM_SYSTEM
:
3073 case GFC_ISYM_TIME8
:
3074 case GFC_ISYM_UMASK
:
3075 case GFC_ISYM_UNLINK
:
3076 gfc_conv_intrinsic_funcall (se
, expr
);
3080 gfc_conv_intrinsic_lib_function (se
, expr
);
3086 /* This generates code to execute before entering the scalarization loop.
3087 Currently does nothing. */
3090 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3092 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3094 case GFC_ISYM_UBOUND
:
3095 case GFC_ISYM_LBOUND
:
3104 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3105 inside the scalarization loop. */
3108 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3112 /* The two argument version returns a scalar. */
3113 if (expr
->value
.function
.actual
->next
->expr
)
3116 newss
= gfc_get_ss ();
3117 newss
->type
= GFC_SS_INTRINSIC
;
3125 /* Walk an intrinsic array libcall. */
3128 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3132 gcc_assert (expr
->rank
> 0);
3134 newss
= gfc_get_ss ();
3135 newss
->type
= GFC_SS_FUNCTION
;
3138 newss
->data
.info
.dimen
= expr
->rank
;
3144 /* Returns nonzero if the specified intrinsic function call maps directly to a
3145 an external library call. Should only be used for functions that return
3149 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3151 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3152 gcc_assert (expr
->rank
> 0);
3154 switch (expr
->value
.function
.isym
->generic_id
)
3158 case GFC_ISYM_COUNT
:
3159 case GFC_ISYM_MATMUL
:
3160 case GFC_ISYM_MAXLOC
:
3161 case GFC_ISYM_MAXVAL
:
3162 case GFC_ISYM_MINLOC
:
3163 case GFC_ISYM_MINVAL
:
3164 case GFC_ISYM_PRODUCT
:
3166 case GFC_ISYM_SHAPE
:
3167 case GFC_ISYM_SPREAD
:
3168 case GFC_ISYM_TRANSPOSE
:
3169 /* Ignore absent optional parameters. */
3172 case GFC_ISYM_RESHAPE
:
3173 case GFC_ISYM_CSHIFT
:
3174 case GFC_ISYM_EOSHIFT
:
3176 case GFC_ISYM_UNPACK
:
3177 /* Pass absent optional parameters. */
3185 /* Walk an intrinsic function. */
3187 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3188 gfc_intrinsic_sym
* isym
)
3192 if (isym
->elemental
)
3193 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_SCALAR
);
3195 if (expr
->rank
== 0)
3198 if (gfc_is_intrinsic_libcall (expr
))
3199 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3201 /* Special cases. */
3202 switch (isym
->generic_id
)
3204 case GFC_ISYM_LBOUND
:
3205 case GFC_ISYM_UBOUND
:
3206 return gfc_walk_intrinsic_bound (ss
, expr
);
3209 /* This probably meant someone forgot to add an intrinsic to the above
3210 list(s) when they implemented it, or something's gone horribly wrong.
3212 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3213 expr
->value
.function
.name
);
3217 #include "gt-fortran-trans-intrinsic.h"