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 ommitted 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
, int op
)
285 return build_fixbound_expr (pblock
, arg
, type
, 0);
289 return build_fixbound_expr (pblock
, arg
, type
, 1);
293 return build_round_expr (pblock
, arg
, type
);
296 return build1 (op
, type
, arg
);
301 /* Round a real value using the specified rounding mode.
302 We use a temporary integer of that same kind size as the result.
303 Values larger than can be represented by this kind are unchanged, as
304 will not be accurate enough to represent the rounding.
305 huge = HUGE (KIND (a))
306 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
310 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, int op
)
321 kind
= expr
->ts
.kind
;
324 /* We have builtin functions for some cases. */
353 /* Evaluate the argument. */
354 gcc_assert (expr
->value
.function
.actual
->expr
);
355 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
357 /* Use a builtin function if one exists. */
358 if (n
!= END_BUILTINS
)
360 tmp
= built_in_decls
[n
];
361 se
->expr
= gfc_build_function_call (tmp
, arg
);
365 /* This code is probably redundant, but we'll keep it lying around just
367 type
= gfc_typenode_for_spec (&expr
->ts
);
368 arg
= TREE_VALUE (arg
);
369 arg
= gfc_evaluate_now (arg
, &se
->pre
);
371 /* Test if the value is too large to handle sensibly. */
372 gfc_set_model_kind (kind
);
374 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
375 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
376 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
377 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
379 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
380 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
381 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
382 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
383 itype
= gfc_get_int_type (kind
);
385 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
386 tmp
= convert (type
, tmp
);
387 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
392 /* Convert to an integer using the specified rounding mode. */
395 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, int op
)
400 /* Evaluate the argument. */
401 type
= gfc_typenode_for_spec (&expr
->ts
);
402 gcc_assert (expr
->value
.function
.actual
->expr
);
403 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
404 arg
= TREE_VALUE (arg
);
406 if (TREE_CODE (TREE_TYPE (arg
)) == INTEGER_TYPE
)
408 /* Conversion to a different integer kind. */
409 se
->expr
= convert (type
, arg
);
413 /* Conversion from complex to non-complex involves taking the real
414 component of the value. */
415 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
416 && expr
->ts
.type
!= BT_COMPLEX
)
420 artype
= TREE_TYPE (TREE_TYPE (arg
));
421 arg
= build1 (REALPART_EXPR
, artype
, arg
);
424 se
->expr
= build_fix_expr (&se
->pre
, arg
, type
, op
);
429 /* Get the imaginary component of a value. */
432 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
436 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
437 arg
= TREE_VALUE (arg
);
438 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
442 /* Get the complex conjugate of a value. */
445 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
449 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
450 arg
= TREE_VALUE (arg
);
451 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
455 /* Initialize function decls for library functions. The external functions
456 are created as required. Builtin functions are added here. */
459 gfc_build_intrinsic_lib_fndecls (void)
461 gfc_intrinsic_map_t
*m
;
463 /* Add GCC builtin functions. */
464 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
466 if (m
->code4
!= END_BUILTINS
)
467 m
->real4_decl
= built_in_decls
[m
->code4
];
468 if (m
->code8
!= END_BUILTINS
)
469 m
->real8_decl
= built_in_decls
[m
->code8
];
474 /* Create a fndecl for a simple intrinsic library function. */
477 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
482 gfc_actual_arglist
*actual
;
485 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
488 if (ts
->type
== BT_REAL
)
493 pdecl
= &m
->real4_decl
;
496 pdecl
= &m
->real8_decl
;
502 else if (ts
->type
== BT_COMPLEX
)
504 gcc_assert (m
->complex_available
);
509 pdecl
= &m
->complex4_decl
;
512 pdecl
= &m
->complex8_decl
;
526 gcc_assert (ts
->kind
== 4 || ts
->kind
== 8);
527 snprintf (name
, sizeof (name
), "%s%s%s",
528 ts
->type
== BT_COMPLEX
? "c" : "",
530 ts
->kind
== 4 ? "f" : "");
534 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
535 ts
->type
== BT_COMPLEX
? 'c' : 'r',
539 argtypes
= NULL_TREE
;
540 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
542 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
543 argtypes
= gfc_chainon_list (argtypes
, type
);
545 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
546 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
547 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
549 /* Mark the decl as external. */
550 DECL_EXTERNAL (fndecl
) = 1;
551 TREE_PUBLIC (fndecl
) = 1;
553 /* Mark it __attribute__((const)), if possible. */
554 TREE_READONLY (fndecl
) = m
->is_constant
;
556 rest_of_decl_compilation (fndecl
, 1, 0);
563 /* Convert an intrinsic function into an external or builtin call. */
566 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
568 gfc_intrinsic_map_t
*m
;
571 gfc_generic_isym_id id
;
573 id
= expr
->value
.function
.isym
->generic_id
;
574 /* Find the entry for this function. */
575 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
581 if (m
->id
== GFC_ISYM_NONE
)
583 internal_error ("Intrinsic function %s(%d) not recognized",
584 expr
->value
.function
.name
, id
);
587 /* Get the decl and generate the call. */
588 args
= gfc_conv_intrinsic_function_args (se
, expr
);
589 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
590 se
->expr
= gfc_build_function_call (fndecl
, args
);
593 /* Generate code for EXPONENT(X) intrinsic function. */
596 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
601 args
= gfc_conv_intrinsic_function_args (se
, expr
);
603 a1
= expr
->value
.function
.actual
->expr
;
607 fndecl
= gfor_fndecl_math_exponent4
;
610 fndecl
= gfor_fndecl_math_exponent8
;
616 se
->expr
= gfc_build_function_call (fndecl
, args
);
619 /* Evaluate a single upper or lower bound. */
620 /* TODO: bound intrinsic generates way too much unnecessary code. */
623 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
625 gfc_actual_arglist
*arg
;
626 gfc_actual_arglist
*arg2
;
636 gfc_init_se (&argse
, NULL
);
637 arg
= expr
->value
.function
.actual
;
642 /* Create an implicit second parameter from the loop variable. */
643 gcc_assert (!arg2
->expr
);
644 gcc_assert (se
->loop
->dimen
== 1);
645 gcc_assert (se
->ss
->expr
== expr
);
646 gfc_advance_se_ss_chain (se
);
647 bound
= se
->loop
->loopvar
[0];
648 bound
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
653 /* use the passed argument. */
654 gcc_assert (arg
->next
->expr
);
655 gfc_init_se (&argse
, NULL
);
656 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
657 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
659 /* Convert from one based to zero based. */
660 bound
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
661 gfc_index_one_node
));
664 /* TODO: don't re-evaluate the descriptor on each iteration. */
665 /* Get a descriptor for the first parameter. */
666 ss
= gfc_walk_expr (arg
->expr
);
667 gcc_assert (ss
!= gfc_ss_terminator
);
668 argse
.want_pointer
= 0;
669 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
670 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
671 gfc_add_block_to_block (&se
->post
, &argse
.post
);
675 if (INTEGER_CST_P (bound
))
677 gcc_assert (TREE_INT_CST_HIGH (bound
) == 0);
678 i
= TREE_INT_CST_LOW (bound
);
679 gcc_assert (i
>= 0 && i
< GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)));
683 if (flag_bounds_check
)
685 bound
= gfc_evaluate_now (bound
, &se
->pre
);
686 cond
= fold (build2 (LT_EXPR
, boolean_type_node
,
687 bound
, build_int_cst (TREE_TYPE (bound
), 0)));
688 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
689 tmp
= fold (build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
));
690 cond
= fold(build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
));
691 gfc_trans_runtime_check (cond
, gfc_strconst_fault
, &se
->pre
);
696 se
->expr
= gfc_conv_descriptor_ubound(desc
, bound
);
698 se
->expr
= gfc_conv_descriptor_lbound(desc
, bound
);
700 type
= gfc_typenode_for_spec (&expr
->ts
);
701 se
->expr
= convert (type
, se
->expr
);
706 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
712 args
= gfc_conv_intrinsic_function_args (se
, expr
);
713 gcc_assert (args
&& TREE_CHAIN (args
) == NULL_TREE
);
714 val
= TREE_VALUE (args
);
716 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
720 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (val
), val
);
724 switch (expr
->ts
.kind
)
735 se
->expr
= fold (gfc_build_function_call (built_in_decls
[n
], args
));
744 /* Create a complex value from one or two real components. */
747 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
754 type
= gfc_typenode_for_spec (&expr
->ts
);
755 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
756 real
= convert (TREE_TYPE (type
), TREE_VALUE (arg
));
758 imag
= convert (TREE_TYPE (type
), TREE_VALUE (TREE_CHAIN (arg
)));
759 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg
))) == COMPLEX_TYPE
)
761 arg
= TREE_VALUE (arg
);
762 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
763 imag
= convert (TREE_TYPE (type
), imag
);
766 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
768 se
->expr
= fold (build2 (COMPLEX_EXPR
, type
, real
, imag
));
771 /* Remainder function MOD(A, P) = A - INT(A / P) * P
772 MODULO(A, P) = A - FLOOR (A / P) * P */
773 /* TODO: MOD(x, 0) */
776 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
788 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
789 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
790 arg
= TREE_VALUE (arg
);
791 type
= TREE_TYPE (arg
);
793 switch (expr
->ts
.type
)
796 /* Integer case is easy, we've got a builtin op. */
798 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, arg
, arg2
);
800 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, arg
, arg2
);
804 /* Real values we have to do the hard way. */
805 arg
= gfc_evaluate_now (arg
, &se
->pre
);
806 arg2
= gfc_evaluate_now (arg2
, &se
->pre
);
808 tmp
= build2 (RDIV_EXPR
, type
, arg
, arg2
);
809 /* Test if the value is too large to handle sensibly. */
810 gfc_set_model_kind (expr
->ts
.kind
);
812 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
813 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
814 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
815 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
817 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
818 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
819 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
820 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
822 itype
= gfc_get_int_type (expr
->ts
.kind
);
824 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_FLOOR_EXPR
);
826 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_TRUNC_EXPR
);
827 tmp
= convert (type
, tmp
);
828 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, arg
);
829 tmp
= build2 (MULT_EXPR
, type
, tmp
, arg2
);
830 se
->expr
= build2 (MINUS_EXPR
, type
, arg
, tmp
);
839 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
842 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
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 val
= build2 (MINUS_EXPR
, type
, arg
, arg2
);
857 val
= gfc_evaluate_now (val
, &se
->pre
);
859 zero
= gfc_build_const (type
, integer_zero_node
);
860 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
861 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
865 /* SIGN(A, B) is absolute value of A times sign of B.
866 The real value versions use library functions to ensure the correct
867 handling of negative zero. Integer case implemented as:
868 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
872 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
883 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
884 if (expr
->ts
.type
== BT_REAL
)
886 switch (expr
->ts
.kind
)
889 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
892 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
897 se
->expr
= fold (gfc_build_function_call (tmp
, arg
));
901 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
902 arg
= TREE_VALUE (arg
);
903 type
= TREE_TYPE (arg
);
904 zero
= gfc_build_const (type
, integer_zero_node
);
906 testa
= fold (build2 (GE_EXPR
, boolean_type_node
, arg
, zero
));
907 testb
= fold (build2 (GE_EXPR
, boolean_type_node
, arg2
, zero
));
908 tmp
= fold (build2 (TRUTH_XOR_EXPR
, boolean_type_node
, testa
, testb
));
909 se
->expr
= fold (build3 (COND_EXPR
, type
, tmp
,
910 build1 (NEGATE_EXPR
, type
, arg
), arg
));
914 /* Test for the presence of an optional argument. */
917 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
921 arg
= expr
->value
.function
.actual
->expr
;
922 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
923 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
924 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
928 /* Calculate the double precision product of two single precision values. */
931 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
937 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
938 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
939 arg
= TREE_VALUE (arg
);
941 /* Convert the args to double precision before multiplying. */
942 type
= gfc_typenode_for_spec (&expr
->ts
);
943 arg
= convert (type
, arg
);
944 arg2
= convert (type
, arg2
);
945 se
->expr
= build2 (MULT_EXPR
, type
, arg
, arg2
);
949 /* Return a length one character string containing an ascii character. */
952 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
958 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
959 arg
= TREE_VALUE (arg
);
961 /* We currently don't support character types != 1. */
962 gcc_assert (expr
->ts
.kind
== 1);
963 type
= gfc_character1_type_node
;
964 var
= gfc_create_var (type
, "char");
966 arg
= convert (type
, arg
);
967 gfc_add_modify_expr (&se
->pre
, var
, arg
);
968 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
969 se
->string_length
= integer_one_node
;
973 /* Get the minimum/maximum value of all the parameters.
974 minmax (a1, a2, a3, ...)
987 /* TODO: Mismatching types can occur when specific names are used.
988 These should be handled during resolution. */
990 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1001 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1002 type
= gfc_typenode_for_spec (&expr
->ts
);
1004 limit
= TREE_VALUE (arg
);
1005 if (TREE_TYPE (limit
) != type
)
1006 limit
= convert (type
, limit
);
1007 /* Only evaluate the argument once. */
1008 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1009 limit
= gfc_evaluate_now(limit
, &se
->pre
);
1011 mvar
= gfc_create_var (type
, "M");
1012 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1013 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1015 val
= TREE_VALUE (arg
);
1016 if (TREE_TYPE (val
) != type
)
1017 val
= convert (type
, val
);
1019 /* Only evaluate the argument once. */
1020 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1021 val
= gfc_evaluate_now(val
, &se
->pre
);
1023 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1025 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1026 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1027 gfc_add_expr_to_block (&se
->pre
, tmp
);
1028 elsecase
= build_empty_stmt ();
1035 /* Create a symbol node for this intrinsic. The symbol form the frontend
1036 is for the generic name. */
1039 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1043 /* TODO: Add symbols for intrinsic function to the global namespace. */
1044 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1045 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1048 sym
->attr
.external
= 1;
1049 sym
->attr
.function
= 1;
1050 sym
->attr
.always_explicit
= 1;
1051 sym
->attr
.proc
= PROC_INTRINSIC
;
1052 sym
->attr
.flavor
= FL_PROCEDURE
;
1056 sym
->attr
.dimension
= 1;
1057 sym
->as
= gfc_get_array_spec ();
1058 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1059 sym
->as
->rank
= expr
->rank
;
1062 /* TODO: proper argument lists for external intrinsics. */
1066 /* Generate a call to an external intrinsic function. */
1068 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1072 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1075 gcc_assert (expr
->rank
> 0);
1077 gcc_assert (expr
->rank
== 0);
1079 sym
= gfc_get_symbol_for_expr (expr
);
1080 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1084 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1104 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1113 gfc_actual_arglist
*actual
;
1120 gfc_conv_intrinsic_funcall (se
, expr
);
1124 actual
= expr
->value
.function
.actual
;
1125 type
= gfc_typenode_for_spec (&expr
->ts
);
1126 /* Initialize the result. */
1127 resvar
= gfc_create_var (type
, "test");
1129 tmp
= convert (type
, boolean_true_node
);
1131 tmp
= convert (type
, boolean_false_node
);
1132 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1134 /* Walk the arguments. */
1135 arrayss
= gfc_walk_expr (actual
->expr
);
1136 gcc_assert (arrayss
!= gfc_ss_terminator
);
1138 /* Initialize the scalarizer. */
1139 gfc_init_loopinfo (&loop
);
1140 exit_label
= gfc_build_label_decl (NULL_TREE
);
1141 TREE_USED (exit_label
) = 1;
1142 gfc_add_ss_to_loop (&loop
, arrayss
);
1144 /* Initialize the loop. */
1145 gfc_conv_ss_startstride (&loop
);
1146 gfc_conv_loop_setup (&loop
);
1148 gfc_mark_ss_chain_used (arrayss
, 1);
1149 /* Generate the loop body. */
1150 gfc_start_scalarized_body (&loop
, &body
);
1152 /* If the condition matches then set the return value. */
1153 gfc_start_block (&block
);
1155 tmp
= convert (type
, boolean_false_node
);
1157 tmp
= convert (type
, boolean_true_node
);
1158 gfc_add_modify_expr (&block
, resvar
, tmp
);
1160 /* And break out of the loop. */
1161 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1162 gfc_add_expr_to_block (&block
, tmp
);
1164 found
= gfc_finish_block (&block
);
1166 /* Check this element. */
1167 gfc_init_se (&arrayse
, NULL
);
1168 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1169 arrayse
.ss
= arrayss
;
1170 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1172 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1173 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
,
1174 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1175 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1176 gfc_add_expr_to_block (&body
, tmp
);
1177 gfc_add_block_to_block (&body
, &arrayse
.post
);
1179 gfc_trans_scalarizing_loops (&loop
, &body
);
1181 /* Add the exit label. */
1182 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1183 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1185 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1186 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1187 gfc_cleanup_loop (&loop
);
1192 /* COUNT(A) = Number of true elements in A. */
1194 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1201 gfc_actual_arglist
*actual
;
1207 gfc_conv_intrinsic_funcall (se
, expr
);
1211 actual
= expr
->value
.function
.actual
;
1213 type
= gfc_typenode_for_spec (&expr
->ts
);
1214 /* Initialize the result. */
1215 resvar
= gfc_create_var (type
, "count");
1216 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1218 /* Walk the arguments. */
1219 arrayss
= gfc_walk_expr (actual
->expr
);
1220 gcc_assert (arrayss
!= gfc_ss_terminator
);
1222 /* Initialize the scalarizer. */
1223 gfc_init_loopinfo (&loop
);
1224 gfc_add_ss_to_loop (&loop
, arrayss
);
1226 /* Initialize the loop. */
1227 gfc_conv_ss_startstride (&loop
);
1228 gfc_conv_loop_setup (&loop
);
1230 gfc_mark_ss_chain_used (arrayss
, 1);
1231 /* Generate the loop body. */
1232 gfc_start_scalarized_body (&loop
, &body
);
1234 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1235 build_int_cst (TREE_TYPE (resvar
), 1));
1236 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1238 gfc_init_se (&arrayse
, NULL
);
1239 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1240 arrayse
.ss
= arrayss
;
1241 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1242 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1244 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1245 gfc_add_expr_to_block (&body
, tmp
);
1246 gfc_add_block_to_block (&body
, &arrayse
.post
);
1248 gfc_trans_scalarizing_loops (&loop
, &body
);
1250 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1251 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1252 gfc_cleanup_loop (&loop
);
1257 /* Inline implementation of the sum and product intrinsics. */
1259 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1267 gfc_actual_arglist
*actual
;
1272 gfc_expr
*arrayexpr
;
1277 gfc_conv_intrinsic_funcall (se
, expr
);
1281 type
= gfc_typenode_for_spec (&expr
->ts
);
1282 /* Initialize the result. */
1283 resvar
= gfc_create_var (type
, "val");
1284 if (op
== PLUS_EXPR
)
1285 tmp
= gfc_build_const (type
, integer_zero_node
);
1287 tmp
= gfc_build_const (type
, integer_one_node
);
1289 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1291 /* Walk the arguments. */
1292 actual
= expr
->value
.function
.actual
;
1293 arrayexpr
= actual
->expr
;
1294 arrayss
= gfc_walk_expr (arrayexpr
);
1295 gcc_assert (arrayss
!= gfc_ss_terminator
);
1297 actual
= actual
->next
->next
;
1298 gcc_assert (actual
);
1299 maskexpr
= actual
->expr
;
1302 maskss
= gfc_walk_expr (maskexpr
);
1303 gcc_assert (maskss
!= gfc_ss_terminator
);
1308 /* Initialize the scalarizer. */
1309 gfc_init_loopinfo (&loop
);
1310 gfc_add_ss_to_loop (&loop
, arrayss
);
1312 gfc_add_ss_to_loop (&loop
, maskss
);
1314 /* Initialize the loop. */
1315 gfc_conv_ss_startstride (&loop
);
1316 gfc_conv_loop_setup (&loop
);
1318 gfc_mark_ss_chain_used (arrayss
, 1);
1320 gfc_mark_ss_chain_used (maskss
, 1);
1321 /* Generate the loop body. */
1322 gfc_start_scalarized_body (&loop
, &body
);
1324 /* If we have a mask, only add this element if the mask is set. */
1327 gfc_init_se (&maskse
, NULL
);
1328 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1330 gfc_conv_expr_val (&maskse
, maskexpr
);
1331 gfc_add_block_to_block (&body
, &maskse
.pre
);
1333 gfc_start_block (&block
);
1336 gfc_init_block (&block
);
1338 /* Do the actual summation/product. */
1339 gfc_init_se (&arrayse
, NULL
);
1340 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1341 arrayse
.ss
= arrayss
;
1342 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1343 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1345 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1346 gfc_add_modify_expr (&block
, resvar
, tmp
);
1347 gfc_add_block_to_block (&block
, &arrayse
.post
);
1351 /* We enclose the above in if (mask) {...} . */
1352 tmp
= gfc_finish_block (&block
);
1354 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1357 tmp
= gfc_finish_block (&block
);
1358 gfc_add_expr_to_block (&body
, tmp
);
1360 gfc_trans_scalarizing_loops (&loop
, &body
);
1361 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1362 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1363 gfc_cleanup_loop (&loop
);
1369 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1373 stmtblock_t ifblock
;
1380 gfc_actual_arglist
*actual
;
1385 gfc_expr
*arrayexpr
;
1392 gfc_conv_intrinsic_funcall (se
, expr
);
1396 /* Initialize the result. */
1397 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1398 type
= gfc_typenode_for_spec (&expr
->ts
);
1400 /* Walk the arguments. */
1401 actual
= expr
->value
.function
.actual
;
1402 arrayexpr
= actual
->expr
;
1403 arrayss
= gfc_walk_expr (arrayexpr
);
1404 gcc_assert (arrayss
!= gfc_ss_terminator
);
1406 actual
= actual
->next
->next
;
1407 gcc_assert (actual
);
1408 maskexpr
= actual
->expr
;
1411 maskss
= gfc_walk_expr (maskexpr
);
1412 gcc_assert (maskss
!= gfc_ss_terminator
);
1417 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1418 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1419 switch (arrayexpr
->ts
.type
)
1422 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1426 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1427 arrayexpr
->ts
.kind
);
1434 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1436 tmp
= fold (build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
));
1437 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1439 /* Initialize the scalarizer. */
1440 gfc_init_loopinfo (&loop
);
1441 gfc_add_ss_to_loop (&loop
, arrayss
);
1443 gfc_add_ss_to_loop (&loop
, maskss
);
1445 /* Initialize the loop. */
1446 gfc_conv_ss_startstride (&loop
);
1447 gfc_conv_loop_setup (&loop
);
1449 gcc_assert (loop
.dimen
== 1);
1451 /* Initialize the position to the first element. If the array has zero
1452 size we need to return zero. Otherwise use the first element of the
1453 array, in case all elements are equal to the limit.
1454 i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1455 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
1456 loop
.from
[0], gfc_index_one_node
));
1457 cond
= fold (build2 (GE_EXPR
, boolean_type_node
,
1458 loop
.to
[0], loop
.from
[0]));
1459 tmp
= fold (build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1460 loop
.from
[0], tmp
));
1461 gfc_add_modify_expr (&loop
.pre
, pos
, tmp
);
1463 gfc_mark_ss_chain_used (arrayss
, 1);
1465 gfc_mark_ss_chain_used (maskss
, 1);
1466 /* Generate the loop body. */
1467 gfc_start_scalarized_body (&loop
, &body
);
1469 /* If we have a mask, only check this element if the mask is set. */
1472 gfc_init_se (&maskse
, NULL
);
1473 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1475 gfc_conv_expr_val (&maskse
, maskexpr
);
1476 gfc_add_block_to_block (&body
, &maskse
.pre
);
1478 gfc_start_block (&block
);
1481 gfc_init_block (&block
);
1483 /* Compare with the current limit. */
1484 gfc_init_se (&arrayse
, NULL
);
1485 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1486 arrayse
.ss
= arrayss
;
1487 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1488 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1490 /* We do the following if this is a more extreme value. */
1491 gfc_start_block (&ifblock
);
1493 /* Assign the value to the limit... */
1494 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
1496 /* Remember where we are. */
1497 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
1499 ifbody
= gfc_finish_block (&ifblock
);
1501 /* If it is a more extreme value. */
1502 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1503 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1504 gfc_add_expr_to_block (&block
, tmp
);
1508 /* We enclose the above in if (mask) {...}. */
1509 tmp
= gfc_finish_block (&block
);
1511 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1514 tmp
= gfc_finish_block (&block
);
1515 gfc_add_expr_to_block (&body
, tmp
);
1517 gfc_trans_scalarizing_loops (&loop
, &body
);
1519 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1520 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1521 gfc_cleanup_loop (&loop
);
1523 /* Return a value in the range 1..SIZE(array). */
1524 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
1525 gfc_index_one_node
));
1526 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
));
1527 /* And convert to the required type. */
1528 se
->expr
= convert (type
, tmp
);
1532 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
1541 gfc_actual_arglist
*actual
;
1546 gfc_expr
*arrayexpr
;
1552 gfc_conv_intrinsic_funcall (se
, expr
);
1556 type
= gfc_typenode_for_spec (&expr
->ts
);
1557 /* Initialize the result. */
1558 limit
= gfc_create_var (type
, "limit");
1559 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
1560 switch (expr
->ts
.type
)
1563 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
1567 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
1574 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1576 tmp
= fold (build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
));
1577 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1579 /* Walk the arguments. */
1580 actual
= expr
->value
.function
.actual
;
1581 arrayexpr
= actual
->expr
;
1582 arrayss
= gfc_walk_expr (arrayexpr
);
1583 gcc_assert (arrayss
!= gfc_ss_terminator
);
1585 actual
= actual
->next
->next
;
1586 gcc_assert (actual
);
1587 maskexpr
= actual
->expr
;
1590 maskss
= gfc_walk_expr (maskexpr
);
1591 gcc_assert (maskss
!= gfc_ss_terminator
);
1596 /* Initialize the scalarizer. */
1597 gfc_init_loopinfo (&loop
);
1598 gfc_add_ss_to_loop (&loop
, arrayss
);
1600 gfc_add_ss_to_loop (&loop
, maskss
);
1602 /* Initialize the loop. */
1603 gfc_conv_ss_startstride (&loop
);
1604 gfc_conv_loop_setup (&loop
);
1606 gfc_mark_ss_chain_used (arrayss
, 1);
1608 gfc_mark_ss_chain_used (maskss
, 1);
1609 /* Generate the loop body. */
1610 gfc_start_scalarized_body (&loop
, &body
);
1612 /* If we have a mask, only add this element if the mask is set. */
1615 gfc_init_se (&maskse
, NULL
);
1616 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1618 gfc_conv_expr_val (&maskse
, maskexpr
);
1619 gfc_add_block_to_block (&body
, &maskse
.pre
);
1621 gfc_start_block (&block
);
1624 gfc_init_block (&block
);
1626 /* Compare with the current limit. */
1627 gfc_init_se (&arrayse
, NULL
);
1628 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1629 arrayse
.ss
= arrayss
;
1630 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1631 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1633 /* Assign the value to the limit... */
1634 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
1636 /* If it is a more extreme value. */
1637 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1638 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1639 gfc_add_expr_to_block (&block
, tmp
);
1640 gfc_add_block_to_block (&block
, &arrayse
.post
);
1642 tmp
= gfc_finish_block (&block
);
1644 /* We enclose the above in if (mask) {...}. */
1645 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1646 gfc_add_expr_to_block (&body
, tmp
);
1648 gfc_trans_scalarizing_loops (&loop
, &body
);
1650 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1651 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1652 gfc_cleanup_loop (&loop
);
1657 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1659 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
1666 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1667 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1668 arg
= TREE_VALUE (arg
);
1669 type
= TREE_TYPE (arg
);
1671 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1672 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
1673 tmp
= fold (build2 (NE_EXPR
, boolean_type_node
, tmp
,
1674 build_int_cst (type
, 0)));
1675 type
= gfc_typenode_for_spec (&expr
->ts
);
1676 se
->expr
= convert (type
, tmp
);
1679 /* Generate code to perform the specified operation. */
1681 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
1687 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1688 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1689 arg
= TREE_VALUE (arg
);
1690 type
= TREE_TYPE (arg
);
1692 se
->expr
= fold (build2 (op
, type
, arg
, arg2
));
1697 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
1701 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1702 arg
= TREE_VALUE (arg
);
1704 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
1707 /* Set or clear a single bit. */
1709 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
1717 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1718 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1719 arg
= TREE_VALUE (arg
);
1720 type
= TREE_TYPE (arg
);
1722 tmp
= fold (build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
));
1728 tmp
= fold (build1 (BIT_NOT_EXPR
, type
, tmp
));
1730 se
->expr
= fold (build2 (op
, type
, arg
, tmp
));
1733 /* Extract a sequence of bits.
1734 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1736 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
1745 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1746 arg2
= TREE_CHAIN (arg
);
1747 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
1748 arg
= TREE_VALUE (arg
);
1749 arg2
= TREE_VALUE (arg2
);
1750 type
= TREE_TYPE (arg
);
1752 mask
= build_int_cst (NULL_TREE
, -1);
1753 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
1754 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
1756 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
1758 se
->expr
= fold (build2 (BIT_AND_EXPR
, type
, tmp
, mask
));
1761 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1763 : ((shift >= 0) ? i << shift : i >> -shift)
1764 where all shifts are logical shifts. */
1766 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
1779 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1780 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1781 arg
= TREE_VALUE (arg
);
1782 type
= TREE_TYPE (arg
);
1783 utype
= gfc_unsigned_type (type
);
1785 width
= fold (build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
));
1787 /* Left shift if positive. */
1788 lshift
= fold (build2 (LSHIFT_EXPR
, type
, arg
, width
));
1790 /* Right shift if negative.
1791 We convert to an unsigned type because we want a logical shift.
1792 The standard doesn't define the case of shifting negative
1793 numbers, and we try to be compatible with other compilers, most
1794 notably g77, here. */
1795 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
1796 convert (type
, arg
), width
));
1798 tmp
= fold (build2 (GE_EXPR
, boolean_type_node
, arg2
,
1799 build_int_cst (TREE_TYPE (arg2
), 0)));
1800 tmp
= fold (build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
));
1802 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1803 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1805 num_bits
= build_int_cst (TREE_TYPE (arg2
), TYPE_PRECISION (type
));
1806 cond
= fold (build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
));
1808 se
->expr
= fold (build3 (COND_EXPR
, type
, cond
,
1809 build_int_cst (type
, 0), tmp
));
1812 /* Circular shift. AKA rotate or barrel shift. */
1814 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
1825 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1826 arg2
= TREE_CHAIN (arg
);
1827 arg3
= TREE_CHAIN (arg2
);
1830 /* Use a library function for the 3 parameter version. */
1831 tree int4type
= gfc_get_int_type (4);
1833 type
= TREE_TYPE (TREE_VALUE (arg
));
1834 /* We convert the first argument to at least 4 bytes, and
1835 convert back afterwards. This removes the need for library
1836 functions for all argument sizes, and function will be
1837 aligned to at least 32 bits, so there's no loss. */
1838 if (expr
->ts
.kind
< 4)
1840 tmp
= convert (int4type
, TREE_VALUE (arg
));
1841 TREE_VALUE (arg
) = tmp
;
1843 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1844 need loads of library functions. They cannot have values >
1845 BIT_SIZE (I) so the conversion is safe. */
1846 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
1847 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
1849 switch (expr
->ts
.kind
)
1854 tmp
= gfor_fndecl_math_ishftc4
;
1857 tmp
= gfor_fndecl_math_ishftc8
;
1862 se
->expr
= gfc_build_function_call (tmp
, arg
);
1863 /* Convert the result back to the original type, if we extended
1864 the first argument's width above. */
1865 if (expr
->ts
.kind
< 4)
1866 se
->expr
= convert (type
, se
->expr
);
1870 arg
= TREE_VALUE (arg
);
1871 arg2
= TREE_VALUE (arg2
);
1872 type
= TREE_TYPE (arg
);
1874 /* Rotate left if positive. */
1875 lrot
= fold (build2 (LROTATE_EXPR
, type
, arg
, arg2
));
1877 /* Rotate right if negative. */
1878 tmp
= fold (build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
));
1879 rrot
= fold (build2 (RROTATE_EXPR
, type
, arg
, tmp
));
1881 zero
= build_int_cst (TREE_TYPE (arg2
), 0);
1882 tmp
= fold (build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
));
1883 rrot
= fold (build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
));
1885 /* Do nothing if shift == 0. */
1886 tmp
= fold (build2 (EQ_EXPR
, boolean_type_node
, arg2
, zero
));
1887 se
->expr
= fold (build3 (COND_EXPR
, type
, tmp
, arg
, rrot
));
1890 /* The length of a character string. */
1892 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
1901 gcc_assert (!se
->ss
);
1903 arg
= expr
->value
.function
.actual
->expr
;
1905 type
= gfc_typenode_for_spec (&expr
->ts
);
1906 switch (arg
->expr_type
)
1909 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
1913 if (arg
->expr_type
== EXPR_VARIABLE
1914 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
1915 && arg
->ref
->type
== REF_ARRAY
)))
1917 /* This doesn't catch all cases.
1918 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1919 and the surrounding thread. */
1920 sym
= arg
->symtree
->n
.sym
;
1921 decl
= gfc_get_symbol_decl (sym
);
1922 if (decl
== current_function_decl
&& sym
->attr
.function
1923 && (sym
->result
== sym
))
1924 decl
= gfc_get_fake_result_decl (sym
);
1926 len
= sym
->ts
.cl
->backend_decl
;
1931 /* Anybody stupid enough to do this deserves inefficient code. */
1932 gfc_init_se (&argse
, se
);
1933 gfc_conv_expr (&argse
, arg
);
1934 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1935 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1936 len
= argse
.string_length
;
1940 se
->expr
= convert (type
, len
);
1943 /* The length of a character string not including trailing blanks. */
1945 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
1950 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1951 type
= gfc_typenode_for_spec (&expr
->ts
);
1952 se
->expr
= gfc_build_function_call (gfor_fndecl_string_len_trim
, args
);
1953 se
->expr
= convert (type
, se
->expr
);
1957 /* Returns the starting position of a substring within a string. */
1960 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
1962 tree logical4_type_node
= gfc_get_logical_type (4);
1968 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1969 type
= gfc_typenode_for_spec (&expr
->ts
);
1970 tmp
= gfc_advance_chain (args
, 3);
1971 if (TREE_CHAIN (tmp
) == NULL_TREE
)
1973 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
1975 TREE_CHAIN (tmp
) = back
;
1979 back
= TREE_CHAIN (tmp
);
1980 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
1983 se
->expr
= gfc_build_function_call (gfor_fndecl_string_index
, args
);
1984 se
->expr
= convert (type
, se
->expr
);
1987 /* The ascii value for a single character. */
1989 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
1994 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1995 arg
= TREE_VALUE (TREE_CHAIN (arg
));
1996 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
1997 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
1998 type
= gfc_typenode_for_spec (&expr
->ts
);
2000 se
->expr
= gfc_build_indirect_ref (arg
);
2001 se
->expr
= convert (type
, se
->expr
);
2005 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2008 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2017 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2018 if (expr
->ts
.type
!= BT_CHARACTER
)
2020 tsource
= TREE_VALUE (arg
);
2021 arg
= TREE_CHAIN (arg
);
2022 fsource
= TREE_VALUE (arg
);
2023 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2027 /* We do the same as in the non-character case, but the argument
2028 list is different because of the string length arguments. We
2029 also have to set the string length for the result. */
2030 len
= TREE_VALUE (arg
);
2031 arg
= TREE_CHAIN (arg
);
2032 tsource
= TREE_VALUE (arg
);
2033 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2034 fsource
= TREE_VALUE (arg
);
2035 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2037 se
->string_length
= len
;
2039 type
= TREE_TYPE (tsource
);
2040 se
->expr
= fold (build3 (COND_EXPR
, type
, mask
, tsource
, fsource
));
2045 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2047 gfc_actual_arglist
*actual
;
2054 gfc_init_se (&argse
, NULL
);
2055 actual
= expr
->value
.function
.actual
;
2057 ss
= gfc_walk_expr (actual
->expr
);
2058 gcc_assert (ss
!= gfc_ss_terminator
);
2059 argse
.want_pointer
= 1;
2060 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2061 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2062 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2063 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2065 actual
= actual
->next
;
2068 gfc_init_se (&argse
, NULL
);
2069 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2070 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2071 args
= gfc_chainon_list (args
, argse
.expr
);
2072 fndecl
= gfor_fndecl_size1
;
2075 fndecl
= gfor_fndecl_size0
;
2077 se
->expr
= gfc_build_function_call (fndecl
, args
);
2078 type
= gfc_typenode_for_spec (&expr
->ts
);
2079 se
->expr
= convert (type
, se
->expr
);
2083 /* Intrinsic string comparison functions. */
2086 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2091 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2092 /* Build a call for the comparison. */
2093 se
->expr
= gfc_build_function_call (gfor_fndecl_compare_string
, args
);
2095 type
= gfc_typenode_for_spec (&expr
->ts
);
2096 se
->expr
= build2 (op
, type
, se
->expr
,
2097 build_int_cst (TREE_TYPE (se
->expr
), 0));
2100 /* Generate a call to the adjustl/adjustr library function. */
2102 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2110 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2111 len
= TREE_VALUE (args
);
2113 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2114 var
= gfc_conv_string_tmp (se
, type
, len
);
2115 args
= tree_cons (NULL_TREE
, var
, args
);
2117 tmp
= gfc_build_function_call (fndecl
, args
);
2118 gfc_add_expr_to_block (&se
->pre
, tmp
);
2120 se
->string_length
= len
;
2124 /* Scalar transfer statement.
2125 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2128 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2130 gfc_actual_arglist
*arg
;
2136 gcc_assert (!se
->ss
);
2138 /* Get a pointer to the source. */
2139 arg
= expr
->value
.function
.actual
;
2140 ss
= gfc_walk_expr (arg
->expr
);
2141 gfc_init_se (&argse
, NULL
);
2142 if (ss
== gfc_ss_terminator
)
2143 gfc_conv_expr_reference (&argse
, arg
->expr
);
2145 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2146 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2147 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2151 type
= gfc_typenode_for_spec (&expr
->ts
);
2152 ptr
= convert (build_pointer_type (type
), ptr
);
2153 if (expr
->ts
.type
== BT_CHARACTER
)
2155 gfc_init_se (&argse
, NULL
);
2156 gfc_conv_expr (&argse
, arg
->expr
);
2157 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2158 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2160 se
->string_length
= argse
.string_length
;
2164 se
->expr
= gfc_build_indirect_ref (ptr
);
2169 /* Generate code for the ALLOCATED intrinsic.
2170 Generate inline code that directly check the address of the argument. */
2173 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2175 gfc_actual_arglist
*arg1
;
2180 gfc_init_se (&arg1se
, NULL
);
2181 arg1
= expr
->value
.function
.actual
;
2182 ss1
= gfc_walk_expr (arg1
->expr
);
2183 arg1se
.descriptor_only
= 1;
2184 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2186 tmp
= gfc_conv_descriptor_data (arg1se
.expr
);
2187 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2188 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2189 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2193 /* Generate code for the ASSOCIATED intrinsic.
2194 If both POINTER and TARGET are arrays, generate a call to library function
2195 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2196 In other cases, generate inline code that directly compare the address of
2197 POINTER with the address of TARGET. */
2200 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2202 gfc_actual_arglist
*arg1
;
2203 gfc_actual_arglist
*arg2
;
2211 gfc_init_se (&arg1se
, NULL
);
2212 gfc_init_se (&arg2se
, NULL
);
2213 arg1
= expr
->value
.function
.actual
;
2215 ss1
= gfc_walk_expr (arg1
->expr
);
2219 /* No optional target. */
2220 if (ss1
== gfc_ss_terminator
)
2222 /* A pointer to a scalar. */
2223 arg1se
.want_pointer
= 1;
2224 gfc_conv_expr (&arg1se
, arg1
->expr
);
2229 /* A pointer to an array. */
2230 arg1se
.descriptor_only
= 1;
2231 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2232 tmp2
= gfc_conv_descriptor_data (arg1se
.expr
);
2234 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2235 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2240 /* An optional target. */
2241 ss2
= gfc_walk_expr (arg2
->expr
);
2242 if (ss1
== gfc_ss_terminator
)
2244 /* A pointer to a scalar. */
2245 gcc_assert (ss2
== gfc_ss_terminator
);
2246 arg1se
.want_pointer
= 1;
2247 gfc_conv_expr (&arg1se
, arg1
->expr
);
2248 arg2se
.want_pointer
= 1;
2249 gfc_conv_expr (&arg2se
, arg2
->expr
);
2250 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2255 /* A pointer to an array, call library function _gfor_associated. */
2256 gcc_assert (ss2
!= gfc_ss_terminator
);
2258 arg1se
.want_pointer
= 1;
2259 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2260 args
= gfc_chainon_list (args
, arg1se
.expr
);
2261 arg2se
.want_pointer
= 1;
2262 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2263 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2264 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2265 args
= gfc_chainon_list (args
, arg2se
.expr
);
2266 fndecl
= gfor_fndecl_associated
;
2267 se
->expr
= gfc_build_function_call (fndecl
, args
);
2270 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2274 /* Scan a string for any one of the characters in a set of characters. */
2277 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2279 tree logical4_type_node
= gfc_get_logical_type (4);
2285 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2286 type
= gfc_typenode_for_spec (&expr
->ts
);
2287 tmp
= gfc_advance_chain (args
, 3);
2288 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2290 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2292 TREE_CHAIN (tmp
) = back
;
2296 back
= TREE_CHAIN (tmp
);
2297 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2300 se
->expr
= gfc_build_function_call (gfor_fndecl_string_scan
, args
);
2301 se
->expr
= convert (type
, se
->expr
);
2305 /* Verify that a set of characters contains all the characters in a string
2306 by identifying the position of the first character in a string of
2307 characters that does not appear in a given set of characters. */
2310 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2312 tree logical4_type_node
= gfc_get_logical_type (4);
2318 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2319 type
= gfc_typenode_for_spec (&expr
->ts
);
2320 tmp
= gfc_advance_chain (args
, 3);
2321 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2323 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2325 TREE_CHAIN (tmp
) = back
;
2329 back
= TREE_CHAIN (tmp
);
2330 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2333 se
->expr
= gfc_build_function_call (gfor_fndecl_string_verify
, args
);
2334 se
->expr
= convert (type
, se
->expr
);
2337 /* Prepare components and related information of a real number which is
2338 the first argument of a elemental functions to manipulate reals. */
2341 prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2342 real_compnt_info
* rcs
, int all
)
2349 tree exponent
, fraction
;
2353 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2354 gfc_todo_error ("Non-IEEE floating format");
2356 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2358 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2359 arg
= TREE_VALUE (arg
);
2360 rcs
->type
= TREE_TYPE (arg
);
2362 /* Force arg'type to integer by unaffected convert */
2363 a1
= expr
->value
.function
.actual
->expr
;
2364 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2365 rcs
->mtype
= masktype
;
2366 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2367 arg
= gfc_create_var (masktype
, "arg");
2368 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2371 /* Calculate the numbers of bits of exponent, fraction and word */
2372 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2373 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2374 rcs
->fdigits
= convert (masktype
, tmp
);
2375 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2376 wbits
= convert (masktype
, wbits
);
2377 rcs
->edigits
= fold (build2 (MINUS_EXPR
, masktype
, wbits
, tmp
));
2379 /* Form masks for exponent/fraction/sign */
2380 one
= gfc_build_const (masktype
, integer_one_node
);
2381 rcs
->smask
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, wbits
));
2382 rcs
->f1
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
));
2383 rcs
->emask
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
));
2384 rcs
->fmask
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
));
2386 tmp
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
));
2387 tmp
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, tmp
));
2388 rcs
->bias
= fold (build2 (MINUS_EXPR
, masktype
, tmp
,one
));
2392 /* exponent, and fraction */
2393 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2394 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2395 exponent
= gfc_create_var (masktype
, "exponent");
2396 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2397 rcs
->expn
= exponent
;
2399 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2400 fraction
= gfc_create_var (masktype
, "fraction");
2401 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2402 rcs
->frac
= fraction
;
2406 /* Build a call to __builtin_clz. */
2409 call_builtin_clz (tree result_type
, tree op0
)
2411 tree fn
, parms
, call
;
2412 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2414 if (op0_mode
== TYPE_MODE (integer_type_node
))
2415 fn
= built_in_decls
[BUILT_IN_CLZ
];
2416 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2417 fn
= built_in_decls
[BUILT_IN_CLZL
];
2418 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2419 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2423 parms
= tree_cons (NULL
, op0
, NULL
);
2424 call
= gfc_build_function_call (fn
, parms
);
2426 return convert (result_type
, call
);
2430 /* Generate code for SPACING (X) intrinsic function.
2431 SPACING (X) = POW (2, e-p)
2435 t = expn - fdigits // e - p.
2436 res = t << fdigits // Form the exponent. Fraction is zero.
2437 if (t < 0) // The result is out of range. Denormalized case.
2442 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2449 real_compnt_info rcs
;
2451 prepare_arg_info (se
, expr
, &rcs
, 0);
2453 masktype
= rcs
.mtype
;
2454 fdigits
= rcs
.fdigits
;
2456 zero
= gfc_build_const (masktype
, integer_zero_node
);
2457 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
2458 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2459 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
2460 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
2461 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2462 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
2463 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2468 /* Generate code for RRSPACING (X) intrinsic function.
2469 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2471 So the result's exponent is p. And if X is normalized, X's fraction part
2472 is the result's fraction. If X is denormalized, to get the X's fraction we
2473 shift X's fraction part to left until the first '1' is removed.
2477 if (expn == 0 && frac == 0)
2481 // edigits is the number of exponent bits. Add the sign bit.
2482 sedigits = edigits + 1;
2484 if (expn == 0) // Denormalized case.
2486 t1 = leadzero (frac);
2487 frac = frac << (t1 + 1); //Remove the first '1'.
2488 frac = frac >> (sedigits); //Form the fraction.
2491 //fdigits is the number of fraction bits. Form the exponent.
2494 res = (t << fdigits) | frac;
2499 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
2502 tree tmp
, t1
, t2
, cond
, cond2
;
2504 tree fdigits
, fraction
;
2505 real_compnt_info rcs
;
2507 prepare_arg_info (se
, expr
, &rcs
, 1);
2508 masktype
= rcs
.mtype
;
2509 fdigits
= rcs
.fdigits
;
2510 fraction
= rcs
.frac
;
2511 one
= gfc_build_const (masktype
, integer_one_node
);
2512 zero
= gfc_build_const (masktype
, integer_zero_node
);
2513 t2
= fold (build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
));
2515 t1
= call_builtin_clz (masktype
, fraction
);
2516 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
2517 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
2518 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
2519 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
2520 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
2522 tmp
= fold (build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
));
2523 tmp
= fold (build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
));
2524 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
2526 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
2527 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
2528 tmp
= build3 (COND_EXPR
, masktype
, cond
,
2529 build_int_cst (masktype
, 0), tmp
);
2531 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2535 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2538 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
2542 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2543 args
= TREE_VALUE (args
);
2544 args
= gfc_build_addr_expr (NULL
, args
);
2545 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
2546 se
->expr
= gfc_build_function_call (gfor_fndecl_si_kind
, args
);
2549 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2552 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
2554 gfc_actual_arglist
*actual
;
2559 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2561 gfc_init_se (&argse
, se
);
2563 /* Pass a NULL pointer for an absent arg. */
2564 if (actual
->expr
== NULL
)
2565 argse
.expr
= null_pointer_node
;
2567 gfc_conv_expr_reference (&argse
, actual
->expr
);
2569 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2570 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2571 args
= gfc_chainon_list (args
, argse
.expr
);
2573 se
->expr
= gfc_build_function_call (gfor_fndecl_sr_kind
, args
);
2577 /* Generate code for TRIM (A) intrinsic function. */
2580 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
2582 tree gfc_int4_type_node
= gfc_get_int_type (4);
2591 arglist
= NULL_TREE
;
2593 type
= build_pointer_type (gfc_character1_type_node
);
2594 var
= gfc_create_var (type
, "pstr");
2595 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
2596 len
= gfc_create_var (gfc_int4_type_node
, "len");
2598 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
2599 arglist
= gfc_chainon_list (arglist
, gfc_build_addr_expr (NULL
, len
));
2600 arglist
= gfc_chainon_list (arglist
, addr
);
2601 arglist
= chainon (arglist
, tmp
);
2603 tmp
= gfc_build_function_call (gfor_fndecl_string_trim
, arglist
);
2604 gfc_add_expr_to_block (&se
->pre
, tmp
);
2606 /* Free the temporary afterwards, if necessary. */
2607 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
2608 build_int_cst (TREE_TYPE (len
), 0));
2609 arglist
= gfc_chainon_list (NULL_TREE
, var
);
2610 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, arglist
);
2611 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2612 gfc_add_expr_to_block (&se
->post
, tmp
);
2615 se
->string_length
= len
;
2619 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2622 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
2624 tree gfc_int4_type_node
= gfc_get_int_type (4);
2633 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2634 len
= TREE_VALUE (args
);
2635 tmp
= gfc_advance_chain (args
, 2);
2636 ncopies
= TREE_VALUE (tmp
);
2637 len
= fold (build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
));
2638 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
2639 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
2641 arglist
= NULL_TREE
;
2642 arglist
= gfc_chainon_list (arglist
, var
);
2643 arglist
= chainon (arglist
, args
);
2644 tmp
= gfc_build_function_call (gfor_fndecl_string_repeat
, arglist
);
2645 gfc_add_expr_to_block (&se
->pre
, tmp
);
2648 se
->string_length
= len
;
2652 /* Generate code for the IARGC intrinsic. If args_only is true this is
2653 actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1. */
2656 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
, bool args_only
)
2662 /* Call the library function. This always returns an INTEGER(4). */
2663 fndecl
= gfor_fndecl_iargc
;
2664 tmp
= gfc_build_function_call (fndecl
, NULL_TREE
);
2666 /* Convert it to the required type. */
2667 type
= gfc_typenode_for_spec (&expr
->ts
);
2668 tmp
= fold_convert (type
, tmp
);
2671 tmp
= build2 (MINUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
2675 /* Generate code for an intrinsic function. Some map directly to library
2676 calls, others get special handling. In some cases the name of the function
2677 used depends on the type specifiers. */
2680 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
2682 gfc_intrinsic_sym
*isym
;
2686 isym
= expr
->value
.function
.isym
;
2688 name
= &expr
->value
.function
.name
[2];
2692 lib
= gfc_is_intrinsic_libcall (expr
);
2696 se
->ignore_optional
= 1;
2697 gfc_conv_intrinsic_funcall (se
, expr
);
2702 switch (expr
->value
.function
.isym
->generic_id
)
2707 case GFC_ISYM_REPEAT
:
2708 gfc_conv_intrinsic_repeat (se
, expr
);
2712 gfc_conv_intrinsic_trim (se
, expr
);
2715 case GFC_ISYM_SI_KIND
:
2716 gfc_conv_intrinsic_si_kind (se
, expr
);
2719 case GFC_ISYM_SR_KIND
:
2720 gfc_conv_intrinsic_sr_kind (se
, expr
);
2723 case GFC_ISYM_EXPONENT
:
2724 gfc_conv_intrinsic_exponent (se
, expr
);
2727 case GFC_ISYM_SPACING
:
2728 gfc_conv_intrinsic_spacing (se
, expr
);
2731 case GFC_ISYM_RRSPACING
:
2732 gfc_conv_intrinsic_rrspacing (se
, expr
);
2736 gfc_conv_intrinsic_scan (se
, expr
);
2739 case GFC_ISYM_VERIFY
:
2740 gfc_conv_intrinsic_verify (se
, expr
);
2743 case GFC_ISYM_ALLOCATED
:
2744 gfc_conv_allocated (se
, expr
);
2747 case GFC_ISYM_ASSOCIATED
:
2748 gfc_conv_associated(se
, expr
);
2752 gfc_conv_intrinsic_abs (se
, expr
);
2755 case GFC_ISYM_ADJUSTL
:
2756 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
2759 case GFC_ISYM_ADJUSTR
:
2760 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
2763 case GFC_ISYM_AIMAG
:
2764 gfc_conv_intrinsic_imagpart (se
, expr
);
2768 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
2772 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
2775 case GFC_ISYM_ANINT
:
2776 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
2780 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
2783 case GFC_ISYM_BTEST
:
2784 gfc_conv_intrinsic_btest (se
, expr
);
2787 case GFC_ISYM_ACHAR
:
2789 gfc_conv_intrinsic_char (se
, expr
);
2792 case GFC_ISYM_CONVERSION
:
2794 case GFC_ISYM_LOGICAL
:
2796 gfc_conv_intrinsic_conversion (se
, expr
);
2799 /* Integer conversions are handled separately to make sure we get the
2800 correct rounding mode. */
2802 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
2806 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
2809 case GFC_ISYM_CEILING
:
2810 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
2813 case GFC_ISYM_FLOOR
:
2814 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
2818 gfc_conv_intrinsic_mod (se
, expr
, 0);
2821 case GFC_ISYM_MODULO
:
2822 gfc_conv_intrinsic_mod (se
, expr
, 1);
2825 case GFC_ISYM_CMPLX
:
2826 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
2829 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
2830 gfc_conv_intrinsic_iargc (se
, expr
, TRUE
);
2833 case GFC_ISYM_CONJG
:
2834 gfc_conv_intrinsic_conjg (se
, expr
);
2837 case GFC_ISYM_COUNT
:
2838 gfc_conv_intrinsic_count (se
, expr
);
2842 gfc_conv_intrinsic_dim (se
, expr
);
2845 case GFC_ISYM_DPROD
:
2846 gfc_conv_intrinsic_dprod (se
, expr
);
2850 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
2853 case GFC_ISYM_IBCLR
:
2854 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
2857 case GFC_ISYM_IBITS
:
2858 gfc_conv_intrinsic_ibits (se
, expr
);
2861 case GFC_ISYM_IBSET
:
2862 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
2865 case GFC_ISYM_IACHAR
:
2866 case GFC_ISYM_ICHAR
:
2867 /* We assume ASCII character sequence. */
2868 gfc_conv_intrinsic_ichar (se
, expr
);
2871 case GFC_ISYM_IARGC
:
2872 gfc_conv_intrinsic_iargc (se
, expr
, FALSE
);
2876 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
2879 case GFC_ISYM_INDEX
:
2880 gfc_conv_intrinsic_index (se
, expr
);
2884 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
2887 case GFC_ISYM_ISHFT
:
2888 gfc_conv_intrinsic_ishft (se
, expr
);
2891 case GFC_ISYM_ISHFTC
:
2892 gfc_conv_intrinsic_ishftc (se
, expr
);
2895 case GFC_ISYM_LBOUND
:
2896 gfc_conv_intrinsic_bound (se
, expr
, 0);
2900 gfc_conv_intrinsic_len (se
, expr
);
2903 case GFC_ISYM_LEN_TRIM
:
2904 gfc_conv_intrinsic_len_trim (se
, expr
);
2908 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
2912 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
2916 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
2920 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
2924 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
2927 case GFC_ISYM_MAXLOC
:
2928 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
2931 case GFC_ISYM_MAXVAL
:
2932 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
2935 case GFC_ISYM_MERGE
:
2936 gfc_conv_intrinsic_merge (se
, expr
);
2940 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
2943 case GFC_ISYM_MINLOC
:
2944 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
2947 case GFC_ISYM_MINVAL
:
2948 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
2952 gfc_conv_intrinsic_not (se
, expr
);
2955 case GFC_ISYM_PRESENT
:
2956 gfc_conv_intrinsic_present (se
, expr
);
2959 case GFC_ISYM_PRODUCT
:
2960 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
2964 gfc_conv_intrinsic_sign (se
, expr
);
2968 gfc_conv_intrinsic_size (se
, expr
);
2972 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
2975 case GFC_ISYM_TRANSFER
:
2976 gfc_conv_intrinsic_transfer (se
, expr
);
2979 case GFC_ISYM_UBOUND
:
2980 gfc_conv_intrinsic_bound (se
, expr
, 1);
2983 case GFC_ISYM_DOT_PRODUCT
:
2984 case GFC_ISYM_ETIME
:
2986 case GFC_ISYM_FSTAT
:
2987 case GFC_ISYM_GETCWD
:
2988 case GFC_ISYM_GETGID
:
2989 case GFC_ISYM_GETPID
:
2990 case GFC_ISYM_GETUID
:
2991 case GFC_ISYM_IRAND
:
2992 case GFC_ISYM_MATMUL
:
2994 case GFC_ISYM_SECOND
:
2996 case GFC_ISYM_SYSTEM
:
2997 case GFC_ISYM_UMASK
:
2998 case GFC_ISYM_UNLINK
:
2999 gfc_conv_intrinsic_funcall (se
, expr
);
3003 gfc_conv_intrinsic_lib_function (se
, expr
);
3009 /* This generates code to execute before entering the scalarization loop.
3010 Currently does nothing. */
3013 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3015 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3017 case GFC_ISYM_UBOUND
:
3018 case GFC_ISYM_LBOUND
:
3027 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3028 inside the scalarization loop. */
3031 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3035 /* The two argument version returns a scalar. */
3036 if (expr
->value
.function
.actual
->next
->expr
)
3039 newss
= gfc_get_ss ();
3040 newss
->type
= GFC_SS_INTRINSIC
;
3048 /* Walk an intrinsic array libcall. */
3051 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3055 gcc_assert (expr
->rank
> 0);
3057 newss
= gfc_get_ss ();
3058 newss
->type
= GFC_SS_FUNCTION
;
3061 newss
->data
.info
.dimen
= expr
->rank
;
3067 /* Returns nonzero if the specified intrinsic function call maps directly to a
3068 an external library call. Should only be used for functions that return
3072 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3074 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3075 gcc_assert (expr
->rank
> 0);
3077 switch (expr
->value
.function
.isym
->generic_id
)
3081 case GFC_ISYM_COUNT
:
3082 case GFC_ISYM_MATMUL
:
3083 case GFC_ISYM_MAXLOC
:
3084 case GFC_ISYM_MAXVAL
:
3085 case GFC_ISYM_MINLOC
:
3086 case GFC_ISYM_MINVAL
:
3087 case GFC_ISYM_PRODUCT
:
3089 case GFC_ISYM_SHAPE
:
3090 case GFC_ISYM_SPREAD
:
3091 case GFC_ISYM_TRANSPOSE
:
3092 /* Ignore absent optional parameters. */
3095 case GFC_ISYM_RESHAPE
:
3096 case GFC_ISYM_CSHIFT
:
3097 case GFC_ISYM_EOSHIFT
:
3099 case GFC_ISYM_UNPACK
:
3100 /* Pass absent optional parameters. */
3108 /* Walk an intrinsic function. */
3110 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3111 gfc_intrinsic_sym
* isym
)
3115 if (isym
->elemental
)
3116 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_SCALAR
);
3118 if (expr
->rank
== 0)
3121 if (gfc_is_intrinsic_libcall (expr
))
3122 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3124 /* Special cases. */
3125 switch (isym
->generic_id
)
3127 case GFC_ISYM_LBOUND
:
3128 case GFC_ISYM_UBOUND
:
3129 return gfc_walk_intrinsic_bound (ss
, expr
);
3132 /* This probably meant someone forgot to add an intrinsic to the above
3133 list(s) when they implemented it, or something's gone horribly wrong.
3135 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3136 expr
->value
.function
.name
);
3140 #include "gt-fortran-trans-intrinsic.h"