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, 59 Temple Place - Suite 330, 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 /* ??? There are now complex variants in builtins.def, though we
56 don't currently do anything with them. */
57 enum built_in_function code4
;
58 enum built_in_function code8
;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc][48]". */
65 /* True if a complex version of the function exists. */
66 bool complex_available
;
68 /* True if the function should be marked const. */
71 /* The base library name of this function. */
74 /* Cache decls created for the various operand types. */
82 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
83 defines complex variants of all of the entries in mathbuiltins.def
85 #define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
86 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
87 HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
89 #define DEFINE_MATH_BUILTIN(id, name, argtype) \
90 BUILT_IN_FUNCTION (id, name, false)
92 /* TODO: Use builtin function for complex intrinsics. */
93 #define DEFINE_MATH_BUILTIN_C(id, name, argtype) \
94 BUILT_IN_FUNCTION (id, name, true)
96 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
97 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
98 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
100 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
102 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
104 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
106 /* Functions built into gcc itself. */
107 #include "mathbuiltins.def"
109 /* Functions in libm. */
110 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
111 pattern for other mathbuiltins.def entries. At present we have no
112 optimizations for this in the common sources. */
113 LIBM_FUNCTION (SCALE
, "scalbn", false),
115 /* Functions in libgfortran. */
116 LIBF_FUNCTION (FRACTION
, "fraction", false),
117 LIBF_FUNCTION (NEAREST
, "nearest", false),
118 LIBF_FUNCTION (SET_EXPONENT
, "set_exponent", false),
121 LIBF_FUNCTION (NONE
, NULL
, false)
123 #undef DEFINE_MATH_BUILTIN
124 #undef DEFINE_MATH_BUILTIN_C
125 #undef BUILT_IN_FUNCTION
129 /* Structure for storing components of a floating number to be used by
130 elemental functions to manipulate reals. */
133 tree arg
; /* Variable tree to view convert to integer. */
134 tree expn
; /* Variable tree to save exponent. */
135 tree frac
; /* Variable tree to save fraction. */
136 tree smask
; /* Constant tree of sign's mask. */
137 tree emask
; /* Constant tree of exponent's mask. */
138 tree fmask
; /* Constant tree of fraction's mask. */
139 tree edigits
; /* Constant tree of the number of exponent bits. */
140 tree fdigits
; /* Constant tree of the number of fraction bits. */
141 tree f1
; /* Constant tree of the f1 defined in the real model. */
142 tree bias
; /* Constant tree of the bias of exponent in the memory. */
143 tree type
; /* Type tree of arg1. */
144 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
149 /* Evaluate the arguments to an intrinsic function. */
152 gfc_conv_intrinsic_function_args (gfc_se
* se
, gfc_expr
* expr
)
154 gfc_actual_arglist
*actual
;
159 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
161 /* Skip omitted optional arguments. */
165 /* Evaluate the parameter. This will substitute scalarized
166 references automatically. */
167 gfc_init_se (&argse
, se
);
169 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
171 gfc_conv_expr (&argse
, actual
->expr
);
172 gfc_conv_string_parameter (&argse
);
173 args
= gfc_chainon_list (args
, argse
.string_length
);
176 gfc_conv_expr_val (&argse
, actual
->expr
);
178 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
179 gfc_add_block_to_block (&se
->post
, &argse
.post
);
180 args
= gfc_chainon_list (args
, argse
.expr
);
186 /* Conversions between different types are output by the frontend as
187 intrinsic functions. We implement these directly with inline code. */
190 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
195 /* Evaluate the argument. */
196 type
= gfc_typenode_for_spec (&expr
->ts
);
197 gcc_assert (expr
->value
.function
.actual
->expr
);
198 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
199 arg
= TREE_VALUE (arg
);
201 /* Conversion from complex to non-complex involves taking the real
202 component of the value. */
203 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
204 && expr
->ts
.type
!= BT_COMPLEX
)
208 artype
= TREE_TYPE (TREE_TYPE (arg
));
209 arg
= build1 (REALPART_EXPR
, artype
, arg
);
212 se
->expr
= convert (type
, arg
);
215 /* This is needed because the gcc backend only implements
216 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
217 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
218 Similarly for CEILING. */
221 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
228 argtype
= TREE_TYPE (arg
);
229 arg
= gfc_evaluate_now (arg
, pblock
);
231 intval
= convert (type
, arg
);
232 intval
= gfc_evaluate_now (intval
, pblock
);
234 tmp
= convert (argtype
, intval
);
235 cond
= build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
237 tmp
= build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
238 build_int_cst (type
, 1));
239 tmp
= build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
244 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
245 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
248 build_round_expr (stmtblock_t
* pblock
, tree arg
, tree type
)
257 argtype
= TREE_TYPE (arg
);
258 arg
= gfc_evaluate_now (arg
, pblock
);
260 real_from_string (&r
, "0.5");
261 pos
= build_real (argtype
, r
);
263 real_from_string (&r
, "-0.5");
264 neg
= build_real (argtype
, r
);
266 tmp
= gfc_build_const (argtype
, integer_zero_node
);
267 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
269 tmp
= fold_build3 (COND_EXPR
, argtype
, cond
, pos
, neg
);
270 tmp
= fold_build2 (PLUS_EXPR
, argtype
, arg
, tmp
);
271 return fold_build1 (FIX_TRUNC_EXPR
, type
, tmp
);
275 /* Convert a real to an integer using a specific rounding mode.
276 Ideally we would just build the corresponding GENERIC node,
277 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
280 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
286 return build_fixbound_expr (pblock
, arg
, type
, 0);
290 return build_fixbound_expr (pblock
, arg
, type
, 1);
294 return build_round_expr (pblock
, arg
, type
);
297 return build1 (op
, type
, arg
);
302 /* Round a real value using the specified rounding mode.
303 We use a temporary integer of that same kind size as the result.
304 Values larger than those that can be represented by this kind are
305 unchanged, as thay will not be accurate enough to represent the
307 huge = HUGE (KIND (a))
308 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
312 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
323 kind
= expr
->ts
.kind
;
326 /* We have builtin functions for some cases. */
359 /* Evaluate the argument. */
360 gcc_assert (expr
->value
.function
.actual
->expr
);
361 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
363 /* Use a builtin function if one exists. */
364 if (n
!= END_BUILTINS
)
366 tmp
= built_in_decls
[n
];
367 se
->expr
= gfc_build_function_call (tmp
, arg
);
371 /* This code is probably redundant, but we'll keep it lying around just
373 type
= gfc_typenode_for_spec (&expr
->ts
);
374 arg
= TREE_VALUE (arg
);
375 arg
= gfc_evaluate_now (arg
, &se
->pre
);
377 /* Test if the value is too large to handle sensibly. */
378 gfc_set_model_kind (kind
);
380 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
381 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
382 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
383 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
385 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
386 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
387 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
388 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
389 itype
= gfc_get_int_type (kind
);
391 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
392 tmp
= convert (type
, tmp
);
393 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
398 /* Convert to an integer using the specified rounding mode. */
401 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, int op
)
406 /* Evaluate the argument. */
407 type
= gfc_typenode_for_spec (&expr
->ts
);
408 gcc_assert (expr
->value
.function
.actual
->expr
);
409 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
410 arg
= TREE_VALUE (arg
);
412 if (TREE_CODE (TREE_TYPE (arg
)) == INTEGER_TYPE
)
414 /* Conversion to a different integer kind. */
415 se
->expr
= convert (type
, arg
);
419 /* Conversion from complex to non-complex involves taking the real
420 component of the value. */
421 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
422 && expr
->ts
.type
!= BT_COMPLEX
)
426 artype
= TREE_TYPE (TREE_TYPE (arg
));
427 arg
= build1 (REALPART_EXPR
, artype
, arg
);
430 se
->expr
= build_fix_expr (&se
->pre
, arg
, type
, op
);
435 /* Get the imaginary component of a value. */
438 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
442 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
443 arg
= TREE_VALUE (arg
);
444 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
448 /* Get the complex conjugate of a value. */
451 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
455 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
456 arg
= TREE_VALUE (arg
);
457 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
461 /* Initialize function decls for library functions. The external functions
462 are created as required. Builtin functions are added here. */
465 gfc_build_intrinsic_lib_fndecls (void)
467 gfc_intrinsic_map_t
*m
;
469 /* Add GCC builtin functions. */
470 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
472 if (m
->code4
!= END_BUILTINS
)
473 m
->real4_decl
= built_in_decls
[m
->code4
];
474 if (m
->code8
!= END_BUILTINS
)
475 m
->real8_decl
= built_in_decls
[m
->code8
];
480 /* Create a fndecl for a simple intrinsic library function. */
483 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
488 gfc_actual_arglist
*actual
;
491 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
494 if (ts
->type
== BT_REAL
)
499 pdecl
= &m
->real4_decl
;
502 pdecl
= &m
->real8_decl
;
508 else if (ts
->type
== BT_COMPLEX
)
510 gcc_assert (m
->complex_available
);
515 pdecl
= &m
->complex4_decl
;
518 pdecl
= &m
->complex8_decl
;
532 gcc_assert (ts
->kind
== 4 || ts
->kind
== 8);
533 snprintf (name
, sizeof (name
), "%s%s%s",
534 ts
->type
== BT_COMPLEX
? "c" : "",
536 ts
->kind
== 4 ? "f" : "");
540 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
541 ts
->type
== BT_COMPLEX
? 'c' : 'r',
545 argtypes
= NULL_TREE
;
546 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
548 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
549 argtypes
= gfc_chainon_list (argtypes
, type
);
551 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
552 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
553 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
555 /* Mark the decl as external. */
556 DECL_EXTERNAL (fndecl
) = 1;
557 TREE_PUBLIC (fndecl
) = 1;
559 /* Mark it __attribute__((const)), if possible. */
560 TREE_READONLY (fndecl
) = m
->is_constant
;
562 rest_of_decl_compilation (fndecl
, 1, 0);
569 /* Convert an intrinsic function into an external or builtin call. */
572 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
574 gfc_intrinsic_map_t
*m
;
577 gfc_generic_isym_id id
;
579 id
= expr
->value
.function
.isym
->generic_id
;
580 /* Find the entry for this function. */
581 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
587 if (m
->id
== GFC_ISYM_NONE
)
589 internal_error ("Intrinsic function %s(%d) not recognized",
590 expr
->value
.function
.name
, id
);
593 /* Get the decl and generate the call. */
594 args
= gfc_conv_intrinsic_function_args (se
, expr
);
595 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
596 se
->expr
= gfc_build_function_call (fndecl
, args
);
599 /* Generate code for EXPONENT(X) intrinsic function. */
602 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
607 args
= gfc_conv_intrinsic_function_args (se
, expr
);
609 a1
= expr
->value
.function
.actual
->expr
;
613 fndecl
= gfor_fndecl_math_exponent4
;
616 fndecl
= gfor_fndecl_math_exponent8
;
622 se
->expr
= gfc_build_function_call (fndecl
, args
);
625 /* Evaluate a single upper or lower bound. */
626 /* TODO: bound intrinsic generates way too much unnecessary code. */
629 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
631 gfc_actual_arglist
*arg
;
632 gfc_actual_arglist
*arg2
;
642 gfc_init_se (&argse
, NULL
);
643 arg
= expr
->value
.function
.actual
;
648 /* Create an implicit second parameter from the loop variable. */
649 gcc_assert (!arg2
->expr
);
650 gcc_assert (se
->loop
->dimen
== 1);
651 gcc_assert (se
->ss
->expr
== expr
);
652 gfc_advance_se_ss_chain (se
);
653 bound
= se
->loop
->loopvar
[0];
654 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
659 /* use the passed argument. */
660 gcc_assert (arg
->next
->expr
);
661 gfc_init_se (&argse
, NULL
);
662 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
663 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
665 /* Convert from one based to zero based. */
666 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
670 /* TODO: don't re-evaluate the descriptor on each iteration. */
671 /* Get a descriptor for the first parameter. */
672 ss
= gfc_walk_expr (arg
->expr
);
673 gcc_assert (ss
!= gfc_ss_terminator
);
674 argse
.want_pointer
= 0;
675 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
676 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
677 gfc_add_block_to_block (&se
->post
, &argse
.post
);
681 if (INTEGER_CST_P (bound
))
683 gcc_assert (TREE_INT_CST_HIGH (bound
) == 0);
684 i
= TREE_INT_CST_LOW (bound
);
685 gcc_assert (i
>= 0 && i
< GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)));
689 if (flag_bounds_check
)
691 bound
= gfc_evaluate_now (bound
, &se
->pre
);
692 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
693 bound
, build_int_cst (TREE_TYPE (bound
), 0));
694 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
695 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
696 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
697 gfc_trans_runtime_check (cond
, gfc_strconst_fault
, &se
->pre
);
702 se
->expr
= gfc_conv_descriptor_ubound(desc
, bound
);
704 se
->expr
= gfc_conv_descriptor_lbound(desc
, bound
);
706 type
= gfc_typenode_for_spec (&expr
->ts
);
707 se
->expr
= convert (type
, se
->expr
);
712 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
718 args
= gfc_conv_intrinsic_function_args (se
, expr
);
719 gcc_assert (args
&& TREE_CHAIN (args
) == NULL_TREE
);
720 val
= TREE_VALUE (args
);
722 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
726 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (val
), val
);
730 switch (expr
->ts
.kind
)
741 se
->expr
= fold (gfc_build_function_call (built_in_decls
[n
], args
));
750 /* Create a complex value from one or two real components. */
753 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
760 type
= gfc_typenode_for_spec (&expr
->ts
);
761 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
762 real
= convert (TREE_TYPE (type
), TREE_VALUE (arg
));
764 imag
= convert (TREE_TYPE (type
), TREE_VALUE (TREE_CHAIN (arg
)));
765 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg
))) == COMPLEX_TYPE
)
767 arg
= TREE_VALUE (arg
);
768 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
769 imag
= convert (TREE_TYPE (type
), imag
);
772 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
774 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
777 /* Remainder function MOD(A, P) = A - INT(A / P) * P
778 MODULO(A, P) = A - FLOOR (A / P) * P */
779 /* TODO: MOD(x, 0) */
782 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
794 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
795 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
796 arg
= TREE_VALUE (arg
);
797 type
= TREE_TYPE (arg
);
799 switch (expr
->ts
.type
)
802 /* Integer case is easy, we've got a builtin op. */
804 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, arg
, arg2
);
806 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, arg
, arg2
);
810 /* Real values we have to do the hard way. */
811 arg
= gfc_evaluate_now (arg
, &se
->pre
);
812 arg2
= gfc_evaluate_now (arg2
, &se
->pre
);
814 tmp
= build2 (RDIV_EXPR
, type
, arg
, arg2
);
815 /* Test if the value is too large to handle sensibly. */
816 gfc_set_model_kind (expr
->ts
.kind
);
818 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
819 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
820 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
821 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
823 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
824 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
825 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
826 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
828 itype
= gfc_get_int_type (expr
->ts
.kind
);
830 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_FLOOR_EXPR
);
832 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_TRUNC_EXPR
);
833 tmp
= convert (type
, tmp
);
834 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, arg
);
835 tmp
= build2 (MULT_EXPR
, type
, tmp
, arg2
);
836 se
->expr
= build2 (MINUS_EXPR
, type
, arg
, tmp
);
845 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
848 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
857 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
858 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
859 arg
= TREE_VALUE (arg
);
860 type
= TREE_TYPE (arg
);
862 val
= build2 (MINUS_EXPR
, type
, arg
, arg2
);
863 val
= gfc_evaluate_now (val
, &se
->pre
);
865 zero
= gfc_build_const (type
, integer_zero_node
);
866 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
867 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
871 /* SIGN(A, B) is absolute value of A times sign of B.
872 The real value versions use library functions to ensure the correct
873 handling of negative zero. Integer case implemented as:
874 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
878 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
889 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
890 if (expr
->ts
.type
== BT_REAL
)
892 switch (expr
->ts
.kind
)
895 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
898 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
903 se
->expr
= fold (gfc_build_function_call (tmp
, arg
));
907 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
908 arg
= TREE_VALUE (arg
);
909 type
= TREE_TYPE (arg
);
910 zero
= gfc_build_const (type
, integer_zero_node
);
912 testa
= fold_build2 (GE_EXPR
, boolean_type_node
, arg
, zero
);
913 testb
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
, zero
);
914 tmp
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, testa
, testb
);
915 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
,
916 build1 (NEGATE_EXPR
, type
, arg
), arg
);
920 /* Test for the presence of an optional argument. */
923 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
927 arg
= expr
->value
.function
.actual
->expr
;
928 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
929 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
930 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
934 /* Calculate the double precision product of two single precision values. */
937 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
943 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
944 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
945 arg
= TREE_VALUE (arg
);
947 /* Convert the args to double precision before multiplying. */
948 type
= gfc_typenode_for_spec (&expr
->ts
);
949 arg
= convert (type
, arg
);
950 arg2
= convert (type
, arg2
);
951 se
->expr
= build2 (MULT_EXPR
, type
, arg
, arg2
);
955 /* Return a length one character string containing an ascii character. */
958 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
964 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
965 arg
= TREE_VALUE (arg
);
967 /* We currently don't support character types != 1. */
968 gcc_assert (expr
->ts
.kind
== 1);
969 type
= gfc_character1_type_node
;
970 var
= gfc_create_var (type
, "char");
972 arg
= convert (type
, arg
);
973 gfc_add_modify_expr (&se
->pre
, var
, arg
);
974 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
975 se
->string_length
= integer_one_node
;
979 /* Get the minimum/maximum value of all the parameters.
980 minmax (a1, a2, a3, ...)
993 /* TODO: Mismatching types can occur when specific names are used.
994 These should be handled during resolution. */
996 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1007 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1008 type
= gfc_typenode_for_spec (&expr
->ts
);
1010 limit
= TREE_VALUE (arg
);
1011 if (TREE_TYPE (limit
) != type
)
1012 limit
= convert (type
, limit
);
1013 /* Only evaluate the argument once. */
1014 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1015 limit
= gfc_evaluate_now(limit
, &se
->pre
);
1017 mvar
= gfc_create_var (type
, "M");
1018 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1019 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1021 val
= TREE_VALUE (arg
);
1022 if (TREE_TYPE (val
) != type
)
1023 val
= convert (type
, val
);
1025 /* Only evaluate the argument once. */
1026 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1027 val
= gfc_evaluate_now(val
, &se
->pre
);
1029 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1031 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1032 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1033 gfc_add_expr_to_block (&se
->pre
, tmp
);
1034 elsecase
= build_empty_stmt ();
1041 /* Create a symbol node for this intrinsic. The symbol from the frontend
1042 has the generic name. */
1045 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1049 /* TODO: Add symbols for intrinsic function to the global namespace. */
1050 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1051 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1054 sym
->attr
.external
= 1;
1055 sym
->attr
.function
= 1;
1056 sym
->attr
.always_explicit
= 1;
1057 sym
->attr
.proc
= PROC_INTRINSIC
;
1058 sym
->attr
.flavor
= FL_PROCEDURE
;
1062 sym
->attr
.dimension
= 1;
1063 sym
->as
= gfc_get_array_spec ();
1064 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1065 sym
->as
->rank
= expr
->rank
;
1068 /* TODO: proper argument lists for external intrinsics. */
1072 /* Generate a call to an external intrinsic function. */
1074 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1078 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1081 gcc_assert (expr
->rank
> 0);
1083 gcc_assert (expr
->rank
== 0);
1085 sym
= gfc_get_symbol_for_expr (expr
);
1086 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1090 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1110 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1119 gfc_actual_arglist
*actual
;
1126 gfc_conv_intrinsic_funcall (se
, expr
);
1130 actual
= expr
->value
.function
.actual
;
1131 type
= gfc_typenode_for_spec (&expr
->ts
);
1132 /* Initialize the result. */
1133 resvar
= gfc_create_var (type
, "test");
1135 tmp
= convert (type
, boolean_true_node
);
1137 tmp
= convert (type
, boolean_false_node
);
1138 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1140 /* Walk the arguments. */
1141 arrayss
= gfc_walk_expr (actual
->expr
);
1142 gcc_assert (arrayss
!= gfc_ss_terminator
);
1144 /* Initialize the scalarizer. */
1145 gfc_init_loopinfo (&loop
);
1146 exit_label
= gfc_build_label_decl (NULL_TREE
);
1147 TREE_USED (exit_label
) = 1;
1148 gfc_add_ss_to_loop (&loop
, arrayss
);
1150 /* Initialize the loop. */
1151 gfc_conv_ss_startstride (&loop
);
1152 gfc_conv_loop_setup (&loop
);
1154 gfc_mark_ss_chain_used (arrayss
, 1);
1155 /* Generate the loop body. */
1156 gfc_start_scalarized_body (&loop
, &body
);
1158 /* If the condition matches then set the return value. */
1159 gfc_start_block (&block
);
1161 tmp
= convert (type
, boolean_false_node
);
1163 tmp
= convert (type
, boolean_true_node
);
1164 gfc_add_modify_expr (&block
, resvar
, tmp
);
1166 /* And break out of the loop. */
1167 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1168 gfc_add_expr_to_block (&block
, tmp
);
1170 found
= gfc_finish_block (&block
);
1172 /* Check this element. */
1173 gfc_init_se (&arrayse
, NULL
);
1174 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1175 arrayse
.ss
= arrayss
;
1176 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1178 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1179 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
,
1180 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1181 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1182 gfc_add_expr_to_block (&body
, tmp
);
1183 gfc_add_block_to_block (&body
, &arrayse
.post
);
1185 gfc_trans_scalarizing_loops (&loop
, &body
);
1187 /* Add the exit label. */
1188 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1189 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1191 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1192 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1193 gfc_cleanup_loop (&loop
);
1198 /* COUNT(A) = Number of true elements in A. */
1200 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1207 gfc_actual_arglist
*actual
;
1213 gfc_conv_intrinsic_funcall (se
, expr
);
1217 actual
= expr
->value
.function
.actual
;
1219 type
= gfc_typenode_for_spec (&expr
->ts
);
1220 /* Initialize the result. */
1221 resvar
= gfc_create_var (type
, "count");
1222 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1224 /* Walk the arguments. */
1225 arrayss
= gfc_walk_expr (actual
->expr
);
1226 gcc_assert (arrayss
!= gfc_ss_terminator
);
1228 /* Initialize the scalarizer. */
1229 gfc_init_loopinfo (&loop
);
1230 gfc_add_ss_to_loop (&loop
, arrayss
);
1232 /* Initialize the loop. */
1233 gfc_conv_ss_startstride (&loop
);
1234 gfc_conv_loop_setup (&loop
);
1236 gfc_mark_ss_chain_used (arrayss
, 1);
1237 /* Generate the loop body. */
1238 gfc_start_scalarized_body (&loop
, &body
);
1240 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1241 build_int_cst (TREE_TYPE (resvar
), 1));
1242 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1244 gfc_init_se (&arrayse
, NULL
);
1245 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1246 arrayse
.ss
= arrayss
;
1247 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1248 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1250 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1251 gfc_add_expr_to_block (&body
, tmp
);
1252 gfc_add_block_to_block (&body
, &arrayse
.post
);
1254 gfc_trans_scalarizing_loops (&loop
, &body
);
1256 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1257 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1258 gfc_cleanup_loop (&loop
);
1263 /* Inline implementation of the sum and product intrinsics. */
1265 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1273 gfc_actual_arglist
*actual
;
1278 gfc_expr
*arrayexpr
;
1283 gfc_conv_intrinsic_funcall (se
, expr
);
1287 type
= gfc_typenode_for_spec (&expr
->ts
);
1288 /* Initialize the result. */
1289 resvar
= gfc_create_var (type
, "val");
1290 if (op
== PLUS_EXPR
)
1291 tmp
= gfc_build_const (type
, integer_zero_node
);
1293 tmp
= gfc_build_const (type
, integer_one_node
);
1295 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1297 /* Walk the arguments. */
1298 actual
= expr
->value
.function
.actual
;
1299 arrayexpr
= actual
->expr
;
1300 arrayss
= gfc_walk_expr (arrayexpr
);
1301 gcc_assert (arrayss
!= gfc_ss_terminator
);
1303 actual
= actual
->next
->next
;
1304 gcc_assert (actual
);
1305 maskexpr
= actual
->expr
;
1308 maskss
= gfc_walk_expr (maskexpr
);
1309 gcc_assert (maskss
!= gfc_ss_terminator
);
1314 /* Initialize the scalarizer. */
1315 gfc_init_loopinfo (&loop
);
1316 gfc_add_ss_to_loop (&loop
, arrayss
);
1318 gfc_add_ss_to_loop (&loop
, maskss
);
1320 /* Initialize the loop. */
1321 gfc_conv_ss_startstride (&loop
);
1322 gfc_conv_loop_setup (&loop
);
1324 gfc_mark_ss_chain_used (arrayss
, 1);
1326 gfc_mark_ss_chain_used (maskss
, 1);
1327 /* Generate the loop body. */
1328 gfc_start_scalarized_body (&loop
, &body
);
1330 /* If we have a mask, only add this element if the mask is set. */
1333 gfc_init_se (&maskse
, NULL
);
1334 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1336 gfc_conv_expr_val (&maskse
, maskexpr
);
1337 gfc_add_block_to_block (&body
, &maskse
.pre
);
1339 gfc_start_block (&block
);
1342 gfc_init_block (&block
);
1344 /* Do the actual summation/product. */
1345 gfc_init_se (&arrayse
, NULL
);
1346 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1347 arrayse
.ss
= arrayss
;
1348 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1349 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1351 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1352 gfc_add_modify_expr (&block
, resvar
, tmp
);
1353 gfc_add_block_to_block (&block
, &arrayse
.post
);
1357 /* We enclose the above in if (mask) {...} . */
1358 tmp
= gfc_finish_block (&block
);
1360 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1363 tmp
= gfc_finish_block (&block
);
1364 gfc_add_expr_to_block (&body
, tmp
);
1366 gfc_trans_scalarizing_loops (&loop
, &body
);
1367 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1368 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1369 gfc_cleanup_loop (&loop
);
1375 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1379 stmtblock_t ifblock
;
1386 gfc_actual_arglist
*actual
;
1391 gfc_expr
*arrayexpr
;
1398 gfc_conv_intrinsic_funcall (se
, expr
);
1402 /* Initialize the result. */
1403 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1404 type
= gfc_typenode_for_spec (&expr
->ts
);
1406 /* Walk the arguments. */
1407 actual
= expr
->value
.function
.actual
;
1408 arrayexpr
= actual
->expr
;
1409 arrayss
= gfc_walk_expr (arrayexpr
);
1410 gcc_assert (arrayss
!= gfc_ss_terminator
);
1412 actual
= actual
->next
->next
;
1413 gcc_assert (actual
);
1414 maskexpr
= actual
->expr
;
1417 maskss
= gfc_walk_expr (maskexpr
);
1418 gcc_assert (maskss
!= gfc_ss_terminator
);
1423 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1424 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1425 switch (arrayexpr
->ts
.type
)
1428 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1432 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1433 arrayexpr
->ts
.kind
);
1440 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1442 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1443 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1445 /* Initialize the scalarizer. */
1446 gfc_init_loopinfo (&loop
);
1447 gfc_add_ss_to_loop (&loop
, arrayss
);
1449 gfc_add_ss_to_loop (&loop
, maskss
);
1451 /* Initialize the loop. */
1452 gfc_conv_ss_startstride (&loop
);
1453 gfc_conv_loop_setup (&loop
);
1455 gcc_assert (loop
.dimen
== 1);
1457 /* Initialize the position to the first element. If the array has zero
1458 size we need to return zero. Otherwise use the first element of the
1459 array, in case all elements are equal to the limit.
1460 i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1461 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1462 loop
.from
[0], gfc_index_one_node
);
1463 cond
= fold_build2 (GE_EXPR
, boolean_type_node
,
1464 loop
.to
[0], loop
.from
[0]);
1465 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1467 gfc_add_modify_expr (&loop
.pre
, pos
, tmp
);
1469 gfc_mark_ss_chain_used (arrayss
, 1);
1471 gfc_mark_ss_chain_used (maskss
, 1);
1472 /* Generate the loop body. */
1473 gfc_start_scalarized_body (&loop
, &body
);
1475 /* If we have a mask, only check this element if the mask is set. */
1478 gfc_init_se (&maskse
, NULL
);
1479 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1481 gfc_conv_expr_val (&maskse
, maskexpr
);
1482 gfc_add_block_to_block (&body
, &maskse
.pre
);
1484 gfc_start_block (&block
);
1487 gfc_init_block (&block
);
1489 /* Compare with the current limit. */
1490 gfc_init_se (&arrayse
, NULL
);
1491 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1492 arrayse
.ss
= arrayss
;
1493 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1494 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1496 /* We do the following if this is a more extreme value. */
1497 gfc_start_block (&ifblock
);
1499 /* Assign the value to the limit... */
1500 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
1502 /* Remember where we are. */
1503 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
1505 ifbody
= gfc_finish_block (&ifblock
);
1507 /* If it is a more extreme value. */
1508 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1509 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1510 gfc_add_expr_to_block (&block
, tmp
);
1514 /* We enclose the above in if (mask) {...}. */
1515 tmp
= gfc_finish_block (&block
);
1517 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1520 tmp
= gfc_finish_block (&block
);
1521 gfc_add_expr_to_block (&body
, tmp
);
1523 gfc_trans_scalarizing_loops (&loop
, &body
);
1525 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1526 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1527 gfc_cleanup_loop (&loop
);
1529 /* Return a value in the range 1..SIZE(array). */
1530 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
1531 gfc_index_one_node
);
1532 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
);
1533 /* And convert to the required type. */
1534 se
->expr
= convert (type
, tmp
);
1538 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
1547 gfc_actual_arglist
*actual
;
1552 gfc_expr
*arrayexpr
;
1558 gfc_conv_intrinsic_funcall (se
, expr
);
1562 type
= gfc_typenode_for_spec (&expr
->ts
);
1563 /* Initialize the result. */
1564 limit
= gfc_create_var (type
, "limit");
1565 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
1566 switch (expr
->ts
.type
)
1569 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
1573 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
1580 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1582 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1583 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1585 /* Walk the arguments. */
1586 actual
= expr
->value
.function
.actual
;
1587 arrayexpr
= actual
->expr
;
1588 arrayss
= gfc_walk_expr (arrayexpr
);
1589 gcc_assert (arrayss
!= gfc_ss_terminator
);
1591 actual
= actual
->next
->next
;
1592 gcc_assert (actual
);
1593 maskexpr
= actual
->expr
;
1596 maskss
= gfc_walk_expr (maskexpr
);
1597 gcc_assert (maskss
!= gfc_ss_terminator
);
1602 /* Initialize the scalarizer. */
1603 gfc_init_loopinfo (&loop
);
1604 gfc_add_ss_to_loop (&loop
, arrayss
);
1606 gfc_add_ss_to_loop (&loop
, maskss
);
1608 /* Initialize the loop. */
1609 gfc_conv_ss_startstride (&loop
);
1610 gfc_conv_loop_setup (&loop
);
1612 gfc_mark_ss_chain_used (arrayss
, 1);
1614 gfc_mark_ss_chain_used (maskss
, 1);
1615 /* Generate the loop body. */
1616 gfc_start_scalarized_body (&loop
, &body
);
1618 /* If we have a mask, only add this element if the mask is set. */
1621 gfc_init_se (&maskse
, NULL
);
1622 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1624 gfc_conv_expr_val (&maskse
, maskexpr
);
1625 gfc_add_block_to_block (&body
, &maskse
.pre
);
1627 gfc_start_block (&block
);
1630 gfc_init_block (&block
);
1632 /* Compare with the current limit. */
1633 gfc_init_se (&arrayse
, NULL
);
1634 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1635 arrayse
.ss
= arrayss
;
1636 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1637 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1639 /* Assign the value to the limit... */
1640 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
1642 /* If it is a more extreme value. */
1643 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1644 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1645 gfc_add_expr_to_block (&block
, tmp
);
1646 gfc_add_block_to_block (&block
, &arrayse
.post
);
1648 tmp
= gfc_finish_block (&block
);
1650 /* We enclose the above in if (mask) {...}. */
1651 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1652 gfc_add_expr_to_block (&body
, tmp
);
1654 gfc_trans_scalarizing_loops (&loop
, &body
);
1656 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1657 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1658 gfc_cleanup_loop (&loop
);
1663 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1665 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
1672 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1673 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1674 arg
= TREE_VALUE (arg
);
1675 type
= TREE_TYPE (arg
);
1677 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1678 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
1679 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
1680 build_int_cst (type
, 0));
1681 type
= gfc_typenode_for_spec (&expr
->ts
);
1682 se
->expr
= convert (type
, tmp
);
1685 /* Generate code to perform the specified operation. */
1687 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
1693 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1694 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1695 arg
= TREE_VALUE (arg
);
1696 type
= TREE_TYPE (arg
);
1698 se
->expr
= fold_build2 (op
, type
, arg
, arg2
);
1703 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
1707 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1708 arg
= TREE_VALUE (arg
);
1710 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
1713 /* Set or clear a single bit. */
1715 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
1723 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1724 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1725 arg
= TREE_VALUE (arg
);
1726 type
= TREE_TYPE (arg
);
1728 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1734 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
1736 se
->expr
= fold_build2 (op
, type
, arg
, tmp
);
1739 /* Extract a sequence of bits.
1740 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1742 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
1751 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1752 arg2
= TREE_CHAIN (arg
);
1753 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
1754 arg
= TREE_VALUE (arg
);
1755 arg2
= TREE_VALUE (arg2
);
1756 type
= TREE_TYPE (arg
);
1758 mask
= build_int_cst (NULL_TREE
, -1);
1759 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
1760 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
1762 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
1764 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
1767 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1769 : ((shift >= 0) ? i << shift : i >> -shift)
1770 where all shifts are logical shifts. */
1772 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
1785 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1786 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1787 arg
= TREE_VALUE (arg
);
1788 type
= TREE_TYPE (arg
);
1789 utype
= gfc_unsigned_type (type
);
1791 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
);
1793 /* Left shift if positive. */
1794 lshift
= fold_build2 (LSHIFT_EXPR
, type
, arg
, width
);
1796 /* Right shift if negative.
1797 We convert to an unsigned type because we want a logical shift.
1798 The standard doesn't define the case of shifting negative
1799 numbers, and we try to be compatible with other compilers, most
1800 notably g77, here. */
1801 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
1802 convert (utype
, arg
), width
));
1804 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
,
1805 build_int_cst (TREE_TYPE (arg2
), 0));
1806 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
1808 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1809 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1811 num_bits
= build_int_cst (TREE_TYPE (arg2
), TYPE_PRECISION (type
));
1812 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
1814 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
1815 build_int_cst (type
, 0), tmp
);
1818 /* Circular shift. AKA rotate or barrel shift. */
1820 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
1831 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1832 arg2
= TREE_CHAIN (arg
);
1833 arg3
= TREE_CHAIN (arg2
);
1836 /* Use a library function for the 3 parameter version. */
1837 tree int4type
= gfc_get_int_type (4);
1839 type
= TREE_TYPE (TREE_VALUE (arg
));
1840 /* We convert the first argument to at least 4 bytes, and
1841 convert back afterwards. This removes the need for library
1842 functions for all argument sizes, and function will be
1843 aligned to at least 32 bits, so there's no loss. */
1844 if (expr
->ts
.kind
< 4)
1846 tmp
= convert (int4type
, TREE_VALUE (arg
));
1847 TREE_VALUE (arg
) = tmp
;
1849 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1850 need loads of library functions. They cannot have values >
1851 BIT_SIZE (I) so the conversion is safe. */
1852 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
1853 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
1855 switch (expr
->ts
.kind
)
1860 tmp
= gfor_fndecl_math_ishftc4
;
1863 tmp
= gfor_fndecl_math_ishftc8
;
1868 se
->expr
= gfc_build_function_call (tmp
, arg
);
1869 /* Convert the result back to the original type, if we extended
1870 the first argument's width above. */
1871 if (expr
->ts
.kind
< 4)
1872 se
->expr
= convert (type
, se
->expr
);
1876 arg
= TREE_VALUE (arg
);
1877 arg2
= TREE_VALUE (arg2
);
1878 type
= TREE_TYPE (arg
);
1880 /* Rotate left if positive. */
1881 lrot
= fold_build2 (LROTATE_EXPR
, type
, arg
, arg2
);
1883 /* Rotate right if negative. */
1884 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
1885 rrot
= fold_build2 (RROTATE_EXPR
, type
, arg
, tmp
);
1887 zero
= build_int_cst (TREE_TYPE (arg2
), 0);
1888 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
);
1889 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
1891 /* Do nothing if shift == 0. */
1892 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg2
, zero
);
1893 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, arg
, rrot
);
1896 /* The length of a character string. */
1898 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
1907 gcc_assert (!se
->ss
);
1909 arg
= expr
->value
.function
.actual
->expr
;
1911 type
= gfc_typenode_for_spec (&expr
->ts
);
1912 switch (arg
->expr_type
)
1915 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
1919 if (arg
->expr_type
== EXPR_VARIABLE
1920 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
1921 && arg
->ref
->type
== REF_ARRAY
)))
1923 /* This doesn't catch all cases.
1924 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1925 and the surrounding thread. */
1926 sym
= arg
->symtree
->n
.sym
;
1927 decl
= gfc_get_symbol_decl (sym
);
1928 if (decl
== current_function_decl
&& sym
->attr
.function
1929 && (sym
->result
== sym
))
1930 decl
= gfc_get_fake_result_decl (sym
);
1932 len
= sym
->ts
.cl
->backend_decl
;
1937 /* Anybody stupid enough to do this deserves inefficient code. */
1938 gfc_init_se (&argse
, se
);
1939 gfc_conv_expr (&argse
, arg
);
1940 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1941 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1942 len
= argse
.string_length
;
1946 se
->expr
= convert (type
, len
);
1949 /* The length of a character string not including trailing blanks. */
1951 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
1956 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1957 type
= gfc_typenode_for_spec (&expr
->ts
);
1958 se
->expr
= gfc_build_function_call (gfor_fndecl_string_len_trim
, args
);
1959 se
->expr
= convert (type
, se
->expr
);
1963 /* Returns the starting position of a substring within a string. */
1966 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
1968 tree logical4_type_node
= gfc_get_logical_type (4);
1974 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1975 type
= gfc_typenode_for_spec (&expr
->ts
);
1976 tmp
= gfc_advance_chain (args
, 3);
1977 if (TREE_CHAIN (tmp
) == NULL_TREE
)
1979 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
1981 TREE_CHAIN (tmp
) = back
;
1985 back
= TREE_CHAIN (tmp
);
1986 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
1989 se
->expr
= gfc_build_function_call (gfor_fndecl_string_index
, args
);
1990 se
->expr
= convert (type
, se
->expr
);
1993 /* The ascii value for a single character. */
1995 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2000 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2001 arg
= TREE_VALUE (TREE_CHAIN (arg
));
2002 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
2003 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
2004 type
= gfc_typenode_for_spec (&expr
->ts
);
2006 se
->expr
= gfc_build_indirect_ref (arg
);
2007 se
->expr
= convert (type
, se
->expr
);
2011 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2014 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2023 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2024 if (expr
->ts
.type
!= BT_CHARACTER
)
2026 tsource
= TREE_VALUE (arg
);
2027 arg
= TREE_CHAIN (arg
);
2028 fsource
= TREE_VALUE (arg
);
2029 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2033 /* We do the same as in the non-character case, but the argument
2034 list is different because of the string length arguments. We
2035 also have to set the string length for the result. */
2036 len
= TREE_VALUE (arg
);
2037 arg
= TREE_CHAIN (arg
);
2038 tsource
= TREE_VALUE (arg
);
2039 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2040 fsource
= TREE_VALUE (arg
);
2041 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2043 se
->string_length
= len
;
2045 type
= TREE_TYPE (tsource
);
2046 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2051 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2053 gfc_actual_arglist
*actual
;
2060 gfc_init_se (&argse
, NULL
);
2061 actual
= expr
->value
.function
.actual
;
2063 ss
= gfc_walk_expr (actual
->expr
);
2064 gcc_assert (ss
!= gfc_ss_terminator
);
2065 argse
.want_pointer
= 1;
2066 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2067 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2068 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2069 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2071 actual
= actual
->next
;
2074 gfc_init_se (&argse
, NULL
);
2075 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2076 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2077 args
= gfc_chainon_list (args
, argse
.expr
);
2078 fndecl
= gfor_fndecl_size1
;
2081 fndecl
= gfor_fndecl_size0
;
2083 se
->expr
= gfc_build_function_call (fndecl
, args
);
2084 type
= gfc_typenode_for_spec (&expr
->ts
);
2085 se
->expr
= convert (type
, se
->expr
);
2089 /* Intrinsic string comparison functions. */
2092 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2097 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2098 /* Build a call for the comparison. */
2099 se
->expr
= gfc_build_function_call (gfor_fndecl_compare_string
, args
);
2101 type
= gfc_typenode_for_spec (&expr
->ts
);
2102 se
->expr
= build2 (op
, type
, se
->expr
,
2103 build_int_cst (TREE_TYPE (se
->expr
), 0));
2106 /* Generate a call to the adjustl/adjustr library function. */
2108 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2116 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2117 len
= TREE_VALUE (args
);
2119 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2120 var
= gfc_conv_string_tmp (se
, type
, len
);
2121 args
= tree_cons (NULL_TREE
, var
, args
);
2123 tmp
= gfc_build_function_call (fndecl
, args
);
2124 gfc_add_expr_to_block (&se
->pre
, tmp
);
2126 se
->string_length
= len
;
2130 /* Scalar transfer statement.
2131 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2134 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2136 gfc_actual_arglist
*arg
;
2142 gcc_assert (!se
->ss
);
2144 /* Get a pointer to the source. */
2145 arg
= expr
->value
.function
.actual
;
2146 ss
= gfc_walk_expr (arg
->expr
);
2147 gfc_init_se (&argse
, NULL
);
2148 if (ss
== gfc_ss_terminator
)
2149 gfc_conv_expr_reference (&argse
, arg
->expr
);
2151 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2152 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2153 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2157 type
= gfc_typenode_for_spec (&expr
->ts
);
2158 ptr
= convert (build_pointer_type (type
), ptr
);
2159 if (expr
->ts
.type
== BT_CHARACTER
)
2161 gfc_init_se (&argse
, NULL
);
2162 gfc_conv_expr (&argse
, arg
->expr
);
2163 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2164 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2166 se
->string_length
= argse
.string_length
;
2170 se
->expr
= gfc_build_indirect_ref (ptr
);
2175 /* Generate code for the ALLOCATED intrinsic.
2176 Generate inline code that directly check the address of the argument. */
2179 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2181 gfc_actual_arglist
*arg1
;
2186 gfc_init_se (&arg1se
, NULL
);
2187 arg1
= expr
->value
.function
.actual
;
2188 ss1
= gfc_walk_expr (arg1
->expr
);
2189 arg1se
.descriptor_only
= 1;
2190 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2192 tmp
= gfc_conv_descriptor_data (arg1se
.expr
);
2193 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2194 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2195 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2199 /* Generate code for the ASSOCIATED intrinsic.
2200 If both POINTER and TARGET are arrays, generate a call to library function
2201 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2202 In other cases, generate inline code that directly compare the address of
2203 POINTER with the address of TARGET. */
2206 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2208 gfc_actual_arglist
*arg1
;
2209 gfc_actual_arglist
*arg2
;
2217 gfc_init_se (&arg1se
, NULL
);
2218 gfc_init_se (&arg2se
, NULL
);
2219 arg1
= expr
->value
.function
.actual
;
2221 ss1
= gfc_walk_expr (arg1
->expr
);
2225 /* No optional target. */
2226 if (ss1
== gfc_ss_terminator
)
2228 /* A pointer to a scalar. */
2229 arg1se
.want_pointer
= 1;
2230 gfc_conv_expr (&arg1se
, arg1
->expr
);
2235 /* A pointer to an array. */
2236 arg1se
.descriptor_only
= 1;
2237 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2238 tmp2
= gfc_conv_descriptor_data (arg1se
.expr
);
2240 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2241 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2246 /* An optional target. */
2247 ss2
= gfc_walk_expr (arg2
->expr
);
2248 if (ss1
== gfc_ss_terminator
)
2250 /* A pointer to a scalar. */
2251 gcc_assert (ss2
== gfc_ss_terminator
);
2252 arg1se
.want_pointer
= 1;
2253 gfc_conv_expr (&arg1se
, arg1
->expr
);
2254 arg2se
.want_pointer
= 1;
2255 gfc_conv_expr (&arg2se
, arg2
->expr
);
2256 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2261 /* A pointer to an array, call library function _gfor_associated. */
2262 gcc_assert (ss2
!= gfc_ss_terminator
);
2264 arg1se
.want_pointer
= 1;
2265 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2266 args
= gfc_chainon_list (args
, arg1se
.expr
);
2267 arg2se
.want_pointer
= 1;
2268 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2269 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2270 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2271 args
= gfc_chainon_list (args
, arg2se
.expr
);
2272 fndecl
= gfor_fndecl_associated
;
2273 se
->expr
= gfc_build_function_call (fndecl
, args
);
2276 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2280 /* Scan a string for any one of the characters in a set of characters. */
2283 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2285 tree logical4_type_node
= gfc_get_logical_type (4);
2291 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2292 type
= gfc_typenode_for_spec (&expr
->ts
);
2293 tmp
= gfc_advance_chain (args
, 3);
2294 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2296 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2298 TREE_CHAIN (tmp
) = back
;
2302 back
= TREE_CHAIN (tmp
);
2303 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2306 se
->expr
= gfc_build_function_call (gfor_fndecl_string_scan
, args
);
2307 se
->expr
= convert (type
, se
->expr
);
2311 /* Verify that a set of characters contains all the characters in a string
2312 by identifying the position of the first character in a string of
2313 characters that does not appear in a given set of characters. */
2316 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2318 tree logical4_type_node
= gfc_get_logical_type (4);
2324 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2325 type
= gfc_typenode_for_spec (&expr
->ts
);
2326 tmp
= gfc_advance_chain (args
, 3);
2327 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2329 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2331 TREE_CHAIN (tmp
) = back
;
2335 back
= TREE_CHAIN (tmp
);
2336 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2339 se
->expr
= gfc_build_function_call (gfor_fndecl_string_verify
, args
);
2340 se
->expr
= convert (type
, se
->expr
);
2343 /* Prepare components and related information of a real number which is
2344 the first argument of a elemental functions to manipulate reals. */
2347 prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2348 real_compnt_info
* rcs
, int all
)
2355 tree exponent
, fraction
;
2359 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2360 gfc_todo_error ("Non-IEEE floating format");
2362 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2364 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2365 arg
= TREE_VALUE (arg
);
2366 rcs
->type
= TREE_TYPE (arg
);
2368 /* Force arg'type to integer by unaffected convert */
2369 a1
= expr
->value
.function
.actual
->expr
;
2370 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2371 rcs
->mtype
= masktype
;
2372 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2373 arg
= gfc_create_var (masktype
, "arg");
2374 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2377 /* Calculate the numbers of bits of exponent, fraction and word */
2378 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2379 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2380 rcs
->fdigits
= convert (masktype
, tmp
);
2381 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2382 wbits
= convert (masktype
, wbits
);
2383 rcs
->edigits
= fold_build2 (MINUS_EXPR
, masktype
, wbits
, tmp
);
2385 /* Form masks for exponent/fraction/sign */
2386 one
= gfc_build_const (masktype
, integer_one_node
);
2387 rcs
->smask
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, wbits
);
2388 rcs
->f1
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
);
2389 rcs
->emask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
);
2390 rcs
->fmask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
);
2392 tmp
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
);
2393 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, tmp
);
2394 rcs
->bias
= fold_build2 (MINUS_EXPR
, masktype
, tmp
,one
);
2398 /* exponent, and fraction */
2399 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2400 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2401 exponent
= gfc_create_var (masktype
, "exponent");
2402 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2403 rcs
->expn
= exponent
;
2405 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2406 fraction
= gfc_create_var (masktype
, "fraction");
2407 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2408 rcs
->frac
= fraction
;
2412 /* Build a call to __builtin_clz. */
2415 call_builtin_clz (tree result_type
, tree op0
)
2417 tree fn
, parms
, call
;
2418 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2420 if (op0_mode
== TYPE_MODE (integer_type_node
))
2421 fn
= built_in_decls
[BUILT_IN_CLZ
];
2422 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2423 fn
= built_in_decls
[BUILT_IN_CLZL
];
2424 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2425 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2429 parms
= tree_cons (NULL
, op0
, NULL
);
2430 call
= gfc_build_function_call (fn
, parms
);
2432 return convert (result_type
, call
);
2436 /* Generate code for SPACING (X) intrinsic function.
2437 SPACING (X) = POW (2, e-p)
2441 t = expn - fdigits // e - p.
2442 res = t << fdigits // Form the exponent. Fraction is zero.
2443 if (t < 0) // The result is out of range. Denormalized case.
2448 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2455 real_compnt_info rcs
;
2457 prepare_arg_info (se
, expr
, &rcs
, 0);
2459 masktype
= rcs
.mtype
;
2460 fdigits
= rcs
.fdigits
;
2462 zero
= gfc_build_const (masktype
, integer_zero_node
);
2463 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
2464 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2465 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
2466 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
2467 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2468 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
2469 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2474 /* Generate code for RRSPACING (X) intrinsic function.
2475 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2477 So the result's exponent is p. And if X is normalized, X's fraction part
2478 is the result's fraction. If X is denormalized, to get the X's fraction we
2479 shift X's fraction part to left until the first '1' is removed.
2483 if (expn == 0 && frac == 0)
2487 // edigits is the number of exponent bits. Add the sign bit.
2488 sedigits = edigits + 1;
2490 if (expn == 0) // Denormalized case.
2492 t1 = leadzero (frac);
2493 frac = frac << (t1 + 1); //Remove the first '1'.
2494 frac = frac >> (sedigits); //Form the fraction.
2497 //fdigits is the number of fraction bits. Form the exponent.
2500 res = (t << fdigits) | frac;
2505 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
2508 tree tmp
, t1
, t2
, cond
, cond2
;
2510 tree fdigits
, fraction
;
2511 real_compnt_info rcs
;
2513 prepare_arg_info (se
, expr
, &rcs
, 1);
2514 masktype
= rcs
.mtype
;
2515 fdigits
= rcs
.fdigits
;
2516 fraction
= rcs
.frac
;
2517 one
= gfc_build_const (masktype
, integer_one_node
);
2518 zero
= gfc_build_const (masktype
, integer_zero_node
);
2519 t2
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
);
2521 t1
= call_builtin_clz (masktype
, fraction
);
2522 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
2523 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
2524 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
2525 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
2526 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
2528 tmp
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
);
2529 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2530 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
2532 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
2533 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
2534 tmp
= build3 (COND_EXPR
, masktype
, cond
,
2535 build_int_cst (masktype
, 0), tmp
);
2537 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2541 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2544 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
2548 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2549 args
= TREE_VALUE (args
);
2550 args
= gfc_build_addr_expr (NULL
, args
);
2551 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
2552 se
->expr
= gfc_build_function_call (gfor_fndecl_si_kind
, args
);
2555 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2558 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
2560 gfc_actual_arglist
*actual
;
2565 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2567 gfc_init_se (&argse
, se
);
2569 /* Pass a NULL pointer for an absent arg. */
2570 if (actual
->expr
== NULL
)
2571 argse
.expr
= null_pointer_node
;
2573 gfc_conv_expr_reference (&argse
, actual
->expr
);
2575 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2576 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2577 args
= gfc_chainon_list (args
, argse
.expr
);
2579 se
->expr
= gfc_build_function_call (gfor_fndecl_sr_kind
, args
);
2583 /* Generate code for TRIM (A) intrinsic function. */
2586 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
2588 tree gfc_int4_type_node
= gfc_get_int_type (4);
2597 arglist
= NULL_TREE
;
2599 type
= build_pointer_type (gfc_character1_type_node
);
2600 var
= gfc_create_var (type
, "pstr");
2601 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
2602 len
= gfc_create_var (gfc_int4_type_node
, "len");
2604 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
2605 arglist
= gfc_chainon_list (arglist
, gfc_build_addr_expr (NULL
, len
));
2606 arglist
= gfc_chainon_list (arglist
, addr
);
2607 arglist
= chainon (arglist
, tmp
);
2609 tmp
= gfc_build_function_call (gfor_fndecl_string_trim
, arglist
);
2610 gfc_add_expr_to_block (&se
->pre
, tmp
);
2612 /* Free the temporary afterwards, if necessary. */
2613 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
2614 build_int_cst (TREE_TYPE (len
), 0));
2615 arglist
= gfc_chainon_list (NULL_TREE
, var
);
2616 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, arglist
);
2617 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2618 gfc_add_expr_to_block (&se
->post
, tmp
);
2621 se
->string_length
= len
;
2625 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2628 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
2630 tree gfc_int4_type_node
= gfc_get_int_type (4);
2639 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2640 len
= TREE_VALUE (args
);
2641 tmp
= gfc_advance_chain (args
, 2);
2642 ncopies
= TREE_VALUE (tmp
);
2643 len
= fold_build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
);
2644 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
2645 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
2647 arglist
= NULL_TREE
;
2648 arglist
= gfc_chainon_list (arglist
, var
);
2649 arglist
= chainon (arglist
, args
);
2650 tmp
= gfc_build_function_call (gfor_fndecl_string_repeat
, arglist
);
2651 gfc_add_expr_to_block (&se
->pre
, tmp
);
2654 se
->string_length
= len
;
2658 /* Generate code for the IARGC intrinsic. */
2661 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
2667 /* Call the library function. This always returns an INTEGER(4). */
2668 fndecl
= gfor_fndecl_iargc
;
2669 tmp
= gfc_build_function_call (fndecl
, NULL_TREE
);
2671 /* Convert it to the required type. */
2672 type
= gfc_typenode_for_spec (&expr
->ts
);
2673 tmp
= fold_convert (type
, tmp
);
2678 /* Generate code for an intrinsic function. Some map directly to library
2679 calls, others get special handling. In some cases the name of the function
2680 used depends on the type specifiers. */
2683 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
2685 gfc_intrinsic_sym
*isym
;
2689 isym
= expr
->value
.function
.isym
;
2691 name
= &expr
->value
.function
.name
[2];
2695 lib
= gfc_is_intrinsic_libcall (expr
);
2699 se
->ignore_optional
= 1;
2700 gfc_conv_intrinsic_funcall (se
, expr
);
2705 switch (expr
->value
.function
.isym
->generic_id
)
2710 case GFC_ISYM_REPEAT
:
2711 gfc_conv_intrinsic_repeat (se
, expr
);
2715 gfc_conv_intrinsic_trim (se
, expr
);
2718 case GFC_ISYM_SI_KIND
:
2719 gfc_conv_intrinsic_si_kind (se
, expr
);
2722 case GFC_ISYM_SR_KIND
:
2723 gfc_conv_intrinsic_sr_kind (se
, expr
);
2726 case GFC_ISYM_EXPONENT
:
2727 gfc_conv_intrinsic_exponent (se
, expr
);
2730 case GFC_ISYM_SPACING
:
2731 gfc_conv_intrinsic_spacing (se
, expr
);
2734 case GFC_ISYM_RRSPACING
:
2735 gfc_conv_intrinsic_rrspacing (se
, expr
);
2739 gfc_conv_intrinsic_scan (se
, expr
);
2742 case GFC_ISYM_VERIFY
:
2743 gfc_conv_intrinsic_verify (se
, expr
);
2746 case GFC_ISYM_ALLOCATED
:
2747 gfc_conv_allocated (se
, expr
);
2750 case GFC_ISYM_ASSOCIATED
:
2751 gfc_conv_associated(se
, expr
);
2755 gfc_conv_intrinsic_abs (se
, expr
);
2758 case GFC_ISYM_ADJUSTL
:
2759 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
2762 case GFC_ISYM_ADJUSTR
:
2763 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
2766 case GFC_ISYM_AIMAG
:
2767 gfc_conv_intrinsic_imagpart (se
, expr
);
2771 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
2775 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
2778 case GFC_ISYM_ANINT
:
2779 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
2783 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
2786 case GFC_ISYM_BTEST
:
2787 gfc_conv_intrinsic_btest (se
, expr
);
2790 case GFC_ISYM_ACHAR
:
2792 gfc_conv_intrinsic_char (se
, expr
);
2795 case GFC_ISYM_CONVERSION
:
2797 case GFC_ISYM_LOGICAL
:
2799 gfc_conv_intrinsic_conversion (se
, expr
);
2802 /* Integer conversions are handled separately to make sure we get the
2803 correct rounding mode. */
2805 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
2809 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
2812 case GFC_ISYM_CEILING
:
2813 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
2816 case GFC_ISYM_FLOOR
:
2817 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
2821 gfc_conv_intrinsic_mod (se
, expr
, 0);
2824 case GFC_ISYM_MODULO
:
2825 gfc_conv_intrinsic_mod (se
, expr
, 1);
2828 case GFC_ISYM_CMPLX
:
2829 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
2832 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
2833 gfc_conv_intrinsic_iargc (se
, expr
);
2836 case GFC_ISYM_CONJG
:
2837 gfc_conv_intrinsic_conjg (se
, expr
);
2840 case GFC_ISYM_COUNT
:
2841 gfc_conv_intrinsic_count (se
, expr
);
2845 gfc_conv_intrinsic_dim (se
, expr
);
2848 case GFC_ISYM_DPROD
:
2849 gfc_conv_intrinsic_dprod (se
, expr
);
2853 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
2856 case GFC_ISYM_IBCLR
:
2857 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
2860 case GFC_ISYM_IBITS
:
2861 gfc_conv_intrinsic_ibits (se
, expr
);
2864 case GFC_ISYM_IBSET
:
2865 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
2868 case GFC_ISYM_IACHAR
:
2869 case GFC_ISYM_ICHAR
:
2870 /* We assume ASCII character sequence. */
2871 gfc_conv_intrinsic_ichar (se
, expr
);
2874 case GFC_ISYM_IARGC
:
2875 gfc_conv_intrinsic_iargc (se
, expr
);
2879 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
2882 case GFC_ISYM_INDEX
:
2883 gfc_conv_intrinsic_index (se
, expr
);
2887 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
2890 case GFC_ISYM_ISHFT
:
2891 gfc_conv_intrinsic_ishft (se
, expr
);
2894 case GFC_ISYM_ISHFTC
:
2895 gfc_conv_intrinsic_ishftc (se
, expr
);
2898 case GFC_ISYM_LBOUND
:
2899 gfc_conv_intrinsic_bound (se
, expr
, 0);
2903 gfc_conv_intrinsic_len (se
, expr
);
2906 case GFC_ISYM_LEN_TRIM
:
2907 gfc_conv_intrinsic_len_trim (se
, expr
);
2911 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
2915 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
2919 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
2923 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
2927 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
2930 case GFC_ISYM_MAXLOC
:
2931 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
2934 case GFC_ISYM_MAXVAL
:
2935 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
2938 case GFC_ISYM_MERGE
:
2939 gfc_conv_intrinsic_merge (se
, expr
);
2943 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
2946 case GFC_ISYM_MINLOC
:
2947 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
2950 case GFC_ISYM_MINVAL
:
2951 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
2955 gfc_conv_intrinsic_not (se
, expr
);
2958 case GFC_ISYM_PRESENT
:
2959 gfc_conv_intrinsic_present (se
, expr
);
2962 case GFC_ISYM_PRODUCT
:
2963 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
2967 gfc_conv_intrinsic_sign (se
, expr
);
2971 gfc_conv_intrinsic_size (se
, expr
);
2975 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
2978 case GFC_ISYM_TRANSFER
:
2979 gfc_conv_intrinsic_transfer (se
, expr
);
2982 case GFC_ISYM_UBOUND
:
2983 gfc_conv_intrinsic_bound (se
, expr
, 1);
2986 case GFC_ISYM_CHDIR
:
2987 case GFC_ISYM_DOT_PRODUCT
:
2988 case GFC_ISYM_ETIME
:
2990 case GFC_ISYM_FSTAT
:
2991 case GFC_ISYM_GETCWD
:
2992 case GFC_ISYM_GETGID
:
2993 case GFC_ISYM_GETPID
:
2994 case GFC_ISYM_GETUID
:
2995 case GFC_ISYM_HOSTNM
:
2997 case GFC_ISYM_IERRNO
:
2998 case GFC_ISYM_IRAND
:
3000 case GFC_ISYM_MATMUL
:
3002 case GFC_ISYM_RENAME
:
3003 case GFC_ISYM_SECOND
:
3005 case GFC_ISYM_SYMLNK
:
3006 case GFC_ISYM_SYSTEM
:
3008 case GFC_ISYM_TIME8
:
3009 case GFC_ISYM_UMASK
:
3010 case GFC_ISYM_UNLINK
:
3011 gfc_conv_intrinsic_funcall (se
, expr
);
3015 gfc_conv_intrinsic_lib_function (se
, expr
);
3021 /* This generates code to execute before entering the scalarization loop.
3022 Currently does nothing. */
3025 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3027 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3029 case GFC_ISYM_UBOUND
:
3030 case GFC_ISYM_LBOUND
:
3039 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3040 inside the scalarization loop. */
3043 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3047 /* The two argument version returns a scalar. */
3048 if (expr
->value
.function
.actual
->next
->expr
)
3051 newss
= gfc_get_ss ();
3052 newss
->type
= GFC_SS_INTRINSIC
;
3060 /* Walk an intrinsic array libcall. */
3063 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3067 gcc_assert (expr
->rank
> 0);
3069 newss
= gfc_get_ss ();
3070 newss
->type
= GFC_SS_FUNCTION
;
3073 newss
->data
.info
.dimen
= expr
->rank
;
3079 /* Returns nonzero if the specified intrinsic function call maps directly to a
3080 an external library call. Should only be used for functions that return
3084 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3086 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3087 gcc_assert (expr
->rank
> 0);
3089 switch (expr
->value
.function
.isym
->generic_id
)
3093 case GFC_ISYM_COUNT
:
3094 case GFC_ISYM_MATMUL
:
3095 case GFC_ISYM_MAXLOC
:
3096 case GFC_ISYM_MAXVAL
:
3097 case GFC_ISYM_MINLOC
:
3098 case GFC_ISYM_MINVAL
:
3099 case GFC_ISYM_PRODUCT
:
3101 case GFC_ISYM_SHAPE
:
3102 case GFC_ISYM_SPREAD
:
3103 case GFC_ISYM_TRANSPOSE
:
3104 /* Ignore absent optional parameters. */
3107 case GFC_ISYM_RESHAPE
:
3108 case GFC_ISYM_CSHIFT
:
3109 case GFC_ISYM_EOSHIFT
:
3111 case GFC_ISYM_UNPACK
:
3112 /* Pass absent optional parameters. */
3120 /* Walk an intrinsic function. */
3122 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3123 gfc_intrinsic_sym
* isym
)
3127 if (isym
->elemental
)
3128 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_SCALAR
);
3130 if (expr
->rank
== 0)
3133 if (gfc_is_intrinsic_libcall (expr
))
3134 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3136 /* Special cases. */
3137 switch (isym
->generic_id
)
3139 case GFC_ISYM_LBOUND
:
3140 case GFC_ISYM_UBOUND
:
3141 return gfc_walk_intrinsic_bound (ss
, expr
);
3144 /* This probably meant someone forgot to add an intrinsic to the above
3145 list(s) when they implemented it, or something's gone horribly wrong.
3147 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3148 expr
->value
.function
.name
);
3152 #include "gt-fortran-trans-intrinsic.h"