1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004 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"
34 #include "tree-gimple.h"
38 #include "intrinsic.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
44 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
45 #include "trans-stmt.h"
47 /* This maps fortran intrinsic math functions to external library or GCC
49 typedef struct gfc_intrinsic_map_t
GTY(())
51 /* The explicit enum is required to work around inadequacies in the
52 garbage collection/gengtype parsing mechanism. */
53 enum gfc_generic_isym_id id
;
55 /* Enum value from the "language-independent", aka C-centric, part
56 of gcc, or END_BUILTINS of no such value set. */
57 /* ??? There are now complex variants in builtins.def, though we
58 don't currently do anything with them. */
59 enum built_in_function code4
;
60 enum built_in_function code8
;
62 /* True if the naming pattern is to prepend "c" for complex and
63 append "f" for kind=4. False if the naming pattern is to
64 prepend "_gfortran_" and append "[rc][48]". */
67 /* True if a complex version of the function exists. */
68 bool complex_available
;
70 /* True if the function should be marked const. */
73 /* The base library name of this function. */
76 /* Cache decls created for the various operand types. */
84 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
85 defines complex variants of all of the entries in mathbuiltins.def
87 #define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
88 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
89 HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
91 #define DEFINE_MATH_BUILTIN(id, name, argtype) \
92 BUILT_IN_FUNCTION (id, name, false)
94 /* TODO: Use builtin function for complex intrinsics. */
95 #define DEFINE_MATH_BUILTIN_C(id, name, argtype) \
96 BUILT_IN_FUNCTION (id, name, true)
98 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
99 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
100 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
102 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
104 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
106 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
108 /* Functions built into gcc itself. */
109 #include "mathbuiltins.def"
111 /* Functions in libm. */
112 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
113 pattern for other mathbuiltins.def entries. At present we have no
114 optimizations for this in the common sources. */
115 LIBM_FUNCTION (SCALE
, "scalbn", false),
117 /* Functions in libgfortran. */
118 LIBF_FUNCTION (FRACTION
, "fraction", false),
119 LIBF_FUNCTION (NEAREST
, "nearest", false),
120 LIBF_FUNCTION (SET_EXPONENT
, "set_exponent", false),
123 LIBF_FUNCTION (NONE
, NULL
, false)
125 #undef DEFINE_MATH_BUILTIN
126 #undef DEFINE_MATH_BUILTIN_C
127 #undef BUILT_IN_FUNCTION
131 /* Structure for storing components of a floating number to be used by
132 elemental functions to manipulate reals. */
135 tree arg
; /* Variable tree to view convert to integer. */
136 tree expn
; /* Variable tree to save exponent. */
137 tree frac
; /* Variable tree to save fraction. */
138 tree smask
; /* Constant tree of sign's mask. */
139 tree emask
; /* Constant tree of exponent's mask. */
140 tree fmask
; /* Constant tree of fraction's mask. */
141 tree edigits
; /* Constant tree of bit numbers of exponent. */
142 tree fdigits
; /* Constant tree of bit numbers of fraction. */
143 tree f1
; /* Constant tree of the f1 defined in the real model. */
144 tree bias
; /* Constant tree of the bias of exponent in the memory. */
145 tree type
; /* Type tree of arg1. */
146 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
151 /* Evaluate the arguments to an intrinsic function. */
154 gfc_conv_intrinsic_function_args (gfc_se
* se
, gfc_expr
* expr
)
156 gfc_actual_arglist
*actual
;
161 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
163 /* Skip ommitted optional arguments. */
167 /* Evaluate the parameter. This will substitute scalarized
168 references automatically. */
169 gfc_init_se (&argse
, se
);
171 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
173 gfc_conv_expr (&argse
, actual
->expr
);
174 gfc_conv_string_parameter (&argse
);
175 args
= gfc_chainon_list (args
, argse
.string_length
);
178 gfc_conv_expr_val (&argse
, actual
->expr
);
180 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
181 gfc_add_block_to_block (&se
->post
, &argse
.post
);
182 args
= gfc_chainon_list (args
, argse
.expr
);
188 /* Conversions between different types are output by the frontend as
189 intrinsic functions. We implement these directly with inline code. */
192 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
197 /* Evaluate the argument. */
198 type
= gfc_typenode_for_spec (&expr
->ts
);
199 gcc_assert (expr
->value
.function
.actual
->expr
);
200 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
201 arg
= TREE_VALUE (arg
);
203 /* Conversion from complex to non-complex involves taking the real
204 component of the value. */
205 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
206 && expr
->ts
.type
!= BT_COMPLEX
)
210 artype
= TREE_TYPE (TREE_TYPE (arg
));
211 arg
= build1 (REALPART_EXPR
, artype
, arg
);
214 se
->expr
= convert (type
, arg
);
218 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
219 TRUNC(x) = INT(x) <= x ? INT(x) : INT(x) - 1
220 Similarly for CEILING. */
223 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
230 argtype
= TREE_TYPE (arg
);
231 arg
= gfc_evaluate_now (arg
, pblock
);
233 intval
= convert (type
, arg
);
234 intval
= gfc_evaluate_now (intval
, pblock
);
236 tmp
= convert (argtype
, intval
);
237 cond
= build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
239 tmp
= build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
240 convert (type
, integer_one_node
));
241 tmp
= build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
246 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
247 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
250 build_round_expr (stmtblock_t
* pblock
, tree arg
, tree type
)
259 argtype
= TREE_TYPE (arg
);
260 arg
= gfc_evaluate_now (arg
, pblock
);
262 real_from_string (&r
, "0.5");
263 pos
= build_real (argtype
, r
);
265 real_from_string (&r
, "-0.5");
266 neg
= build_real (argtype
, r
);
268 tmp
= gfc_build_const (argtype
, integer_zero_node
);
269 cond
= fold (build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
));
271 tmp
= fold (build3 (COND_EXPR
, argtype
, cond
, pos
, neg
));
272 tmp
= fold (build2 (PLUS_EXPR
, argtype
, arg
, tmp
));
273 return fold (build1 (FIX_TRUNC_EXPR
, type
, tmp
));
277 /* Convert a real to an integer using a specific rounding mode.
278 Ideally we would just build the corresponding GENERIC node,
279 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
282 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int op
)
287 return build_fixbound_expr (pblock
, arg
, type
, 0);
291 return build_fixbound_expr (pblock
, arg
, type
, 1);
295 return build_round_expr (pblock
, arg
, type
);
298 return build1 (op
, type
, arg
);
303 /* Round a real value using the specified rounding mode.
304 We use a temporary integer of that same kind size as the result.
305 Values larger than can be represented by this kind are unchanged, as
306 will not be accurate enough to represent the rounding.
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
, int op
)
323 kind
= expr
->ts
.kind
;
326 /* We have builtin functions for some cases. */
355 /* Evaluate the argument. */
356 gcc_assert (expr
->value
.function
.actual
->expr
);
357 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
359 /* Use a builtin function if one exists. */
360 if (n
!= END_BUILTINS
)
362 tmp
= built_in_decls
[n
];
363 se
->expr
= gfc_build_function_call (tmp
, arg
);
367 /* This code is probably redundant, but we'll keep it lying around just
369 type
= gfc_typenode_for_spec (&expr
->ts
);
370 arg
= TREE_VALUE (arg
);
371 arg
= gfc_evaluate_now (arg
, &se
->pre
);
373 /* Test if the value is too large to handle sensibly. */
374 gfc_set_model_kind (kind
);
376 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
377 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
378 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
379 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
381 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
382 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
383 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
384 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
385 itype
= gfc_get_int_type (kind
);
387 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
388 tmp
= convert (type
, tmp
);
389 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
394 /* Convert to an integer using the specified rounding mode. */
397 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, int op
)
402 /* Evaluate the argument. */
403 type
= gfc_typenode_for_spec (&expr
->ts
);
404 gcc_assert (expr
->value
.function
.actual
->expr
);
405 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
406 arg
= TREE_VALUE (arg
);
408 if (TREE_CODE (TREE_TYPE (arg
)) == INTEGER_TYPE
)
410 /* Conversion to a different integer kind. */
411 se
->expr
= convert (type
, arg
);
415 /* Conversion from complex to non-complex involves taking the real
416 component of the value. */
417 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
418 && expr
->ts
.type
!= BT_COMPLEX
)
422 artype
= TREE_TYPE (TREE_TYPE (arg
));
423 arg
= build1 (REALPART_EXPR
, artype
, arg
);
426 se
->expr
= build_fix_expr (&se
->pre
, arg
, type
, op
);
431 /* Get the imaginary component of a value. */
434 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
438 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
439 arg
= TREE_VALUE (arg
);
440 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
444 /* Get the complex conjugate of a value. */
447 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
451 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
452 arg
= TREE_VALUE (arg
);
453 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
457 /* Initialize function decls for library functions. The external functions
458 are created as required. Builtin functions are added here. */
461 gfc_build_intrinsic_lib_fndecls (void)
463 gfc_intrinsic_map_t
*m
;
465 /* Add GCC builtin functions. */
466 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
468 if (m
->code4
!= END_BUILTINS
)
469 m
->real4_decl
= built_in_decls
[m
->code4
];
470 if (m
->code8
!= END_BUILTINS
)
471 m
->real8_decl
= built_in_decls
[m
->code8
];
476 /* Create a fndecl for a simple intrinsic library function. */
479 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
484 gfc_actual_arglist
*actual
;
487 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
490 if (ts
->type
== BT_REAL
)
495 pdecl
= &m
->real4_decl
;
498 pdecl
= &m
->real8_decl
;
504 else if (ts
->type
== BT_COMPLEX
)
506 gcc_assert (m
->complex_available
);
511 pdecl
= &m
->complex4_decl
;
514 pdecl
= &m
->complex8_decl
;
528 gcc_assert (ts
->kind
== 4 || ts
->kind
== 8);
529 snprintf (name
, sizeof (name
), "%s%s%s",
530 ts
->type
== BT_COMPLEX
? "c" : "",
532 ts
->kind
== 4 ? "f" : "");
536 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
537 ts
->type
== BT_COMPLEX
? 'c' : 'r',
541 argtypes
= NULL_TREE
;
542 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
544 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
545 argtypes
= gfc_chainon_list (argtypes
, type
);
547 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
548 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
549 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
551 /* Mark the decl as external. */
552 DECL_EXTERNAL (fndecl
) = 1;
553 TREE_PUBLIC (fndecl
) = 1;
555 /* Mark it __attribute__((const)), if possible. */
556 TREE_READONLY (fndecl
) = m
->is_constant
;
558 rest_of_decl_compilation (fndecl
, 1, 0);
565 /* Convert an intrinsic function into an external or builtin call. */
568 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
570 gfc_intrinsic_map_t
*m
;
573 gfc_generic_isym_id id
;
575 id
= expr
->value
.function
.isym
->generic_id
;
576 /* Find the entry for this function. */
577 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
583 if (m
->id
== GFC_ISYM_NONE
)
585 internal_error ("Intrinsic function %s(%d) not recognized",
586 expr
->value
.function
.name
, id
);
589 /* Get the decl and generate the call. */
590 args
= gfc_conv_intrinsic_function_args (se
, expr
);
591 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
592 se
->expr
= gfc_build_function_call (fndecl
, args
);
595 /* Generate code for EXPONENT(X) intrinsic function. */
598 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
603 args
= gfc_conv_intrinsic_function_args (se
, expr
);
605 a1
= expr
->value
.function
.actual
->expr
;
609 fndecl
= gfor_fndecl_math_exponent4
;
612 fndecl
= gfor_fndecl_math_exponent8
;
618 se
->expr
= gfc_build_function_call (fndecl
, args
);
621 /* Evaluate a single upper or lower bound. */
622 /* TODO: bound intrinsic generates way too much unneccessary code. */
625 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
627 gfc_actual_arglist
*arg
;
628 gfc_actual_arglist
*arg2
;
638 gfc_init_se (&argse
, NULL
);
639 arg
= expr
->value
.function
.actual
;
644 /* Create an implicit second parameter from the loop variable. */
645 gcc_assert (!arg2
->expr
);
646 gcc_assert (se
->loop
->dimen
== 1);
647 gcc_assert (se
->ss
->expr
== expr
);
648 gfc_advance_se_ss_chain (se
);
649 bound
= se
->loop
->loopvar
[0];
650 bound
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
655 /* use the passed argument. */
656 gcc_assert (arg
->next
->expr
);
657 gfc_init_se (&argse
, NULL
);
658 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
659 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
661 /* Convert from one based to zero based. */
662 bound
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
663 gfc_index_one_node
));
666 /* TODO: don't re-evaluate the descriptor on each iteration. */
667 /* Get a descriptor for the first parameter. */
668 ss
= gfc_walk_expr (arg
->expr
);
669 gcc_assert (ss
!= gfc_ss_terminator
);
670 argse
.want_pointer
= 0;
671 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
672 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
673 gfc_add_block_to_block (&se
->post
, &argse
.post
);
677 if (INTEGER_CST_P (bound
))
679 gcc_assert (TREE_INT_CST_HIGH (bound
) == 0);
680 i
= TREE_INT_CST_LOW (bound
);
681 gcc_assert (i
>= 0 && i
< GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)));
685 if (flag_bounds_check
)
687 bound
= gfc_evaluate_now (bound
, &se
->pre
);
688 cond
= fold (build2 (LT_EXPR
, boolean_type_node
,
689 bound
, convert (TREE_TYPE (bound
),
690 integer_zero_node
)));
691 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
692 tmp
= fold (build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
));
693 cond
= fold(build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
));
694 gfc_trans_runtime_check (cond
, gfc_strconst_fault
, &se
->pre
);
699 se
->expr
= gfc_conv_descriptor_ubound(desc
, bound
);
701 se
->expr
= gfc_conv_descriptor_lbound(desc
, bound
);
703 type
= gfc_typenode_for_spec (&expr
->ts
);
704 se
->expr
= convert (type
, se
->expr
);
709 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
715 args
= gfc_conv_intrinsic_function_args (se
, expr
);
716 gcc_assert (args
&& TREE_CHAIN (args
) == NULL_TREE
);
717 val
= TREE_VALUE (args
);
719 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
723 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (val
), val
);
727 switch (expr
->ts
.kind
)
738 se
->expr
= fold (gfc_build_function_call (built_in_decls
[n
], args
));
747 /* Create a complex value from one or two real components. */
750 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
757 type
= gfc_typenode_for_spec (&expr
->ts
);
758 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
759 real
= convert (TREE_TYPE (type
), TREE_VALUE (arg
));
761 imag
= convert (TREE_TYPE (type
), TREE_VALUE (TREE_CHAIN (arg
)));
762 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg
))) == COMPLEX_TYPE
)
764 arg
= TREE_VALUE (arg
);
765 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
766 imag
= convert (TREE_TYPE (type
), imag
);
769 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
771 se
->expr
= fold (build2 (COMPLEX_EXPR
, type
, real
, imag
));
774 /* Remainder function MOD(A, P) = A - INT(A / P) * P.
775 MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P. */
776 /* TODO: MOD(x, 0) */
779 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
792 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
793 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
794 arg
= TREE_VALUE (arg
);
795 type
= TREE_TYPE (arg
);
797 switch (expr
->ts
.type
)
800 /* Integer case is easy, we've got a builtin op. */
801 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, arg
, arg2
);
805 /* Real values we have to do the hard way. */
806 arg
= gfc_evaluate_now (arg
, &se
->pre
);
807 arg2
= gfc_evaluate_now (arg2
, &se
->pre
);
809 tmp
= build2 (RDIV_EXPR
, type
, arg
, arg2
);
810 /* Test if the value is too large to handle sensibly. */
811 gfc_set_model_kind (expr
->ts
.kind
);
813 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
814 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
815 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
816 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
818 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
819 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
820 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
821 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
823 itype
= gfc_get_int_type (expr
->ts
.kind
);
824 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_TRUNC_EXPR
);
825 tmp
= convert (type
, tmp
);
826 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, arg
);
827 tmp
= build2 (MULT_EXPR
, type
, tmp
, arg2
);
828 se
->expr
= build2 (MINUS_EXPR
, type
, arg
, tmp
);
838 zero
= gfc_build_const (type
, integer_zero_node
);
839 /* Build !(A > 0 .xor. P > 0). */
840 test
= build2 (GT_EXPR
, boolean_type_node
, arg
, zero
);
841 test2
= build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
);
842 test
= build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
843 test
= build1 (TRUTH_NOT_EXPR
, boolean_type_node
, test
);
844 /* Build (A == 0) .or. !(A > 0 .xor. P > 0). */
845 test2
= build2 (EQ_EXPR
, boolean_type_node
, arg
, zero
);
846 test
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, test
, test2
);
848 se
->expr
= build3 (COND_EXPR
, type
, test
, se
->expr
,
849 build2 (PLUS_EXPR
, type
, se
->expr
, arg2
));
853 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
856 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
865 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
866 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
867 arg
= TREE_VALUE (arg
);
868 type
= TREE_TYPE (arg
);
870 val
= build2 (MINUS_EXPR
, type
, arg
, arg2
);
871 val
= gfc_evaluate_now (val
, &se
->pre
);
873 zero
= gfc_build_const (type
, integer_zero_node
);
874 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
875 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
879 /* SIGN(A, B) is absolute value of A times sign of B.
880 The real value versions use library functions to ensure the correct
881 handling of negative zero. Integer case implemented as:
882 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
886 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
897 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
898 if (expr
->ts
.type
== BT_REAL
)
900 switch (expr
->ts
.kind
)
903 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
906 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
911 se
->expr
= fold (gfc_build_function_call (tmp
, arg
));
915 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
916 arg
= TREE_VALUE (arg
);
917 type
= TREE_TYPE (arg
);
918 zero
= gfc_build_const (type
, integer_zero_node
);
920 testa
= fold (build2 (GE_EXPR
, boolean_type_node
, arg
, zero
));
921 testb
= fold (build2 (GE_EXPR
, boolean_type_node
, arg2
, zero
));
922 tmp
= fold (build2 (TRUTH_XOR_EXPR
, boolean_type_node
, testa
, testb
));
923 se
->expr
= fold (build3 (COND_EXPR
, type
, tmp
,
924 build1 (NEGATE_EXPR
, type
, arg
), arg
));
928 /* Test for the presence of an optional argument. */
931 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
935 arg
= expr
->value
.function
.actual
->expr
;
936 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
937 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
938 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
942 /* Calculate the double precision product of two single precision values. */
945 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
951 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
952 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
953 arg
= TREE_VALUE (arg
);
955 /* Convert the args to double precision before multiplying. */
956 type
= gfc_typenode_for_spec (&expr
->ts
);
957 arg
= convert (type
, arg
);
958 arg2
= convert (type
, arg2
);
959 se
->expr
= build2 (MULT_EXPR
, type
, arg
, arg2
);
963 /* Return a length one character string containing an ascii character. */
966 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
972 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
973 arg
= TREE_VALUE (arg
);
975 /* We currently don't support character types != 1. */
976 gcc_assert (expr
->ts
.kind
== 1);
977 type
= gfc_character1_type_node
;
978 var
= gfc_create_var (type
, "char");
980 arg
= convert (type
, arg
);
981 gfc_add_modify_expr (&se
->pre
, var
, arg
);
982 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
983 se
->string_length
= integer_one_node
;
987 /* Get the minimum/maximum value of all the parameters.
988 minmax (a1, a2, a3, ...)
1001 /* TODO: Mismatching types can occur when specific names are used.
1002 These should be handled during resolution. */
1004 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1015 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1016 type
= gfc_typenode_for_spec (&expr
->ts
);
1018 limit
= TREE_VALUE (arg
);
1019 if (TREE_TYPE (limit
) != type
)
1020 limit
= convert (type
, limit
);
1021 /* Only evaluate the argument once. */
1022 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1023 limit
= gfc_evaluate_now(limit
, &se
->pre
);
1025 mvar
= gfc_create_var (type
, "M");
1026 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1027 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1029 val
= TREE_VALUE (arg
);
1030 if (TREE_TYPE (val
) != type
)
1031 val
= convert (type
, val
);
1033 /* Only evaluate the argument once. */
1034 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1035 val
= gfc_evaluate_now(val
, &se
->pre
);
1037 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1039 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1040 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1041 gfc_add_expr_to_block (&se
->pre
, tmp
);
1042 elsecase
= build_empty_stmt ();
1049 /* Create a symbol node for this intrinsic. The symbol form the frontend
1050 is for the generic name. */
1053 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1057 /* TODO: Add symbols for intrinsic function to the global namespace. */
1058 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1059 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1062 sym
->attr
.external
= 1;
1063 sym
->attr
.function
= 1;
1064 sym
->attr
.always_explicit
= 1;
1065 sym
->attr
.proc
= PROC_INTRINSIC
;
1066 sym
->attr
.flavor
= FL_PROCEDURE
;
1070 sym
->attr
.dimension
= 1;
1071 sym
->as
= gfc_get_array_spec ();
1072 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1073 sym
->as
->rank
= expr
->rank
;
1076 /* TODO: proper argument lists for external intrinsics. */
1080 /* Generate a call to an external intrinsic function. */
1082 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1086 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1089 gcc_assert (expr
->rank
> 0);
1091 gcc_assert (expr
->rank
== 0);
1093 sym
= gfc_get_symbol_for_expr (expr
);
1094 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1098 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1118 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1127 gfc_actual_arglist
*actual
;
1134 gfc_conv_intrinsic_funcall (se
, expr
);
1138 actual
= expr
->value
.function
.actual
;
1139 type
= gfc_typenode_for_spec (&expr
->ts
);
1140 /* Initialize the result. */
1141 resvar
= gfc_create_var (type
, "test");
1143 tmp
= convert (type
, boolean_true_node
);
1145 tmp
= convert (type
, boolean_false_node
);
1146 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1148 /* Walk the arguments. */
1149 arrayss
= gfc_walk_expr (actual
->expr
);
1150 gcc_assert (arrayss
!= gfc_ss_terminator
);
1152 /* Initialize the scalarizer. */
1153 gfc_init_loopinfo (&loop
);
1154 exit_label
= gfc_build_label_decl (NULL_TREE
);
1155 TREE_USED (exit_label
) = 1;
1156 gfc_add_ss_to_loop (&loop
, arrayss
);
1158 /* Initialize the loop. */
1159 gfc_conv_ss_startstride (&loop
);
1160 gfc_conv_loop_setup (&loop
);
1162 gfc_mark_ss_chain_used (arrayss
, 1);
1163 /* Generate the loop body. */
1164 gfc_start_scalarized_body (&loop
, &body
);
1166 /* If the condition matches then set the return value. */
1167 gfc_start_block (&block
);
1169 tmp
= convert (type
, boolean_false_node
);
1171 tmp
= convert (type
, boolean_true_node
);
1172 gfc_add_modify_expr (&block
, resvar
, tmp
);
1174 /* And break out of the loop. */
1175 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1176 gfc_add_expr_to_block (&block
, tmp
);
1178 found
= gfc_finish_block (&block
);
1180 /* Check this element. */
1181 gfc_init_se (&arrayse
, NULL
);
1182 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1183 arrayse
.ss
= arrayss
;
1184 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1186 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1187 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
,
1188 fold_convert (TREE_TYPE (arrayse
.expr
),
1189 integer_zero_node
));
1190 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1191 gfc_add_expr_to_block (&body
, tmp
);
1192 gfc_add_block_to_block (&body
, &arrayse
.post
);
1194 gfc_trans_scalarizing_loops (&loop
, &body
);
1196 /* Add the exit label. */
1197 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1198 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1200 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1201 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1202 gfc_cleanup_loop (&loop
);
1207 /* COUNT(A) = Number of true elements in A. */
1209 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1216 gfc_actual_arglist
*actual
;
1222 gfc_conv_intrinsic_funcall (se
, expr
);
1226 actual
= expr
->value
.function
.actual
;
1228 type
= gfc_typenode_for_spec (&expr
->ts
);
1229 /* Initialize the result. */
1230 resvar
= gfc_create_var (type
, "count");
1231 gfc_add_modify_expr (&se
->pre
, resvar
, convert (type
, integer_zero_node
));
1233 /* Walk the arguments. */
1234 arrayss
= gfc_walk_expr (actual
->expr
);
1235 gcc_assert (arrayss
!= gfc_ss_terminator
);
1237 /* Initialize the scalarizer. */
1238 gfc_init_loopinfo (&loop
);
1239 gfc_add_ss_to_loop (&loop
, arrayss
);
1241 /* Initialize the loop. */
1242 gfc_conv_ss_startstride (&loop
);
1243 gfc_conv_loop_setup (&loop
);
1245 gfc_mark_ss_chain_used (arrayss
, 1);
1246 /* Generate the loop body. */
1247 gfc_start_scalarized_body (&loop
, &body
);
1249 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1250 convert (TREE_TYPE (resvar
), integer_one_node
));
1251 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1253 gfc_init_se (&arrayse
, NULL
);
1254 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1255 arrayse
.ss
= arrayss
;
1256 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1257 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1259 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1260 gfc_add_expr_to_block (&body
, tmp
);
1261 gfc_add_block_to_block (&body
, &arrayse
.post
);
1263 gfc_trans_scalarizing_loops (&loop
, &body
);
1265 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1266 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1267 gfc_cleanup_loop (&loop
);
1272 /* Inline implementation of the sum and product intrinsics. */
1274 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1282 gfc_actual_arglist
*actual
;
1287 gfc_expr
*arrayexpr
;
1292 gfc_conv_intrinsic_funcall (se
, expr
);
1296 type
= gfc_typenode_for_spec (&expr
->ts
);
1297 /* Initialize the result. */
1298 resvar
= gfc_create_var (type
, "val");
1299 if (op
== PLUS_EXPR
)
1300 tmp
= gfc_build_const (type
, integer_zero_node
);
1302 tmp
= gfc_build_const (type
, integer_one_node
);
1304 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1306 /* Walk the arguments. */
1307 actual
= expr
->value
.function
.actual
;
1308 arrayexpr
= actual
->expr
;
1309 arrayss
= gfc_walk_expr (arrayexpr
);
1310 gcc_assert (arrayss
!= gfc_ss_terminator
);
1312 actual
= actual
->next
->next
;
1313 gcc_assert (actual
);
1314 maskexpr
= actual
->expr
;
1317 maskss
= gfc_walk_expr (maskexpr
);
1318 gcc_assert (maskss
!= gfc_ss_terminator
);
1323 /* Initialize the scalarizer. */
1324 gfc_init_loopinfo (&loop
);
1325 gfc_add_ss_to_loop (&loop
, arrayss
);
1327 gfc_add_ss_to_loop (&loop
, maskss
);
1329 /* Initialize the loop. */
1330 gfc_conv_ss_startstride (&loop
);
1331 gfc_conv_loop_setup (&loop
);
1333 gfc_mark_ss_chain_used (arrayss
, 1);
1335 gfc_mark_ss_chain_used (maskss
, 1);
1336 /* Generate the loop body. */
1337 gfc_start_scalarized_body (&loop
, &body
);
1339 /* If we have a mask, only add this element if the mask is set. */
1342 gfc_init_se (&maskse
, NULL
);
1343 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1345 gfc_conv_expr_val (&maskse
, maskexpr
);
1346 gfc_add_block_to_block (&body
, &maskse
.pre
);
1348 gfc_start_block (&block
);
1351 gfc_init_block (&block
);
1353 /* Do the actual summation/product. */
1354 gfc_init_se (&arrayse
, NULL
);
1355 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1356 arrayse
.ss
= arrayss
;
1357 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1358 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1360 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1361 gfc_add_modify_expr (&block
, resvar
, tmp
);
1362 gfc_add_block_to_block (&block
, &arrayse
.post
);
1366 /* We enclose the above in if (mask) {...} . */
1367 tmp
= gfc_finish_block (&block
);
1369 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1372 tmp
= gfc_finish_block (&block
);
1373 gfc_add_expr_to_block (&body
, tmp
);
1375 gfc_trans_scalarizing_loops (&loop
, &body
);
1376 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1377 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1378 gfc_cleanup_loop (&loop
);
1384 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1388 stmtblock_t ifblock
;
1395 gfc_actual_arglist
*actual
;
1400 gfc_expr
*arrayexpr
;
1407 gfc_conv_intrinsic_funcall (se
, expr
);
1411 /* Initialize the result. */
1412 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1413 type
= gfc_typenode_for_spec (&expr
->ts
);
1415 /* Walk the arguments. */
1416 actual
= expr
->value
.function
.actual
;
1417 arrayexpr
= actual
->expr
;
1418 arrayss
= gfc_walk_expr (arrayexpr
);
1419 gcc_assert (arrayss
!= gfc_ss_terminator
);
1421 actual
= actual
->next
->next
;
1422 gcc_assert (actual
);
1423 maskexpr
= actual
->expr
;
1426 maskss
= gfc_walk_expr (maskexpr
);
1427 gcc_assert (maskss
!= gfc_ss_terminator
);
1432 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1433 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1434 switch (arrayexpr
->ts
.type
)
1437 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1441 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1442 arrayexpr
->ts
.kind
);
1449 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1451 tmp
= fold (build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
));
1452 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1454 /* Initialize the scalarizer. */
1455 gfc_init_loopinfo (&loop
);
1456 gfc_add_ss_to_loop (&loop
, arrayss
);
1458 gfc_add_ss_to_loop (&loop
, maskss
);
1460 /* Initialize the loop. */
1461 gfc_conv_ss_startstride (&loop
);
1462 gfc_conv_loop_setup (&loop
);
1464 gcc_assert (loop
.dimen
== 1);
1466 /* Initialize the position to the first element. If the array has zero
1467 size we need to return zero. Otherwise use the first element of the
1468 array, in case all elements are equal to the limit.
1469 ie. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1470 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
1471 loop
.from
[0], gfc_index_one_node
));
1472 cond
= fold (build2 (GE_EXPR
, boolean_type_node
,
1473 loop
.to
[0], loop
.from
[0]));
1474 tmp
= fold (build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1475 loop
.from
[0], tmp
));
1476 gfc_add_modify_expr (&loop
.pre
, pos
, tmp
);
1478 gfc_mark_ss_chain_used (arrayss
, 1);
1480 gfc_mark_ss_chain_used (maskss
, 1);
1481 /* Generate the loop body. */
1482 gfc_start_scalarized_body (&loop
, &body
);
1484 /* If we have a mask, only check this element if the mask is set. */
1487 gfc_init_se (&maskse
, NULL
);
1488 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1490 gfc_conv_expr_val (&maskse
, maskexpr
);
1491 gfc_add_block_to_block (&body
, &maskse
.pre
);
1493 gfc_start_block (&block
);
1496 gfc_init_block (&block
);
1498 /* Compare with the current limit. */
1499 gfc_init_se (&arrayse
, NULL
);
1500 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1501 arrayse
.ss
= arrayss
;
1502 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1503 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1505 /* We do the following if this is a more extreme value. */
1506 gfc_start_block (&ifblock
);
1508 /* Assign the value to the limit... */
1509 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
1511 /* Remember where we are. */
1512 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
1514 ifbody
= gfc_finish_block (&ifblock
);
1516 /* If it is a more extreme value. */
1517 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1518 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1519 gfc_add_expr_to_block (&block
, tmp
);
1523 /* We enclose the above in if (mask) {...}. */
1524 tmp
= gfc_finish_block (&block
);
1526 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1529 tmp
= gfc_finish_block (&block
);
1530 gfc_add_expr_to_block (&body
, tmp
);
1532 gfc_trans_scalarizing_loops (&loop
, &body
);
1534 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1535 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1536 gfc_cleanup_loop (&loop
);
1538 /* Return a value in the range 1..SIZE(array). */
1539 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
1540 gfc_index_one_node
));
1541 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
));
1542 /* And convert to the required type. */
1543 se
->expr
= convert (type
, tmp
);
1547 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
1556 gfc_actual_arglist
*actual
;
1561 gfc_expr
*arrayexpr
;
1567 gfc_conv_intrinsic_funcall (se
, expr
);
1571 type
= gfc_typenode_for_spec (&expr
->ts
);
1572 /* Initialize the result. */
1573 limit
= gfc_create_var (type
, "limit");
1574 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
1575 switch (expr
->ts
.type
)
1578 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
1582 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
1589 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1591 tmp
= fold (build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
));
1592 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1594 /* Walk the arguments. */
1595 actual
= expr
->value
.function
.actual
;
1596 arrayexpr
= actual
->expr
;
1597 arrayss
= gfc_walk_expr (arrayexpr
);
1598 gcc_assert (arrayss
!= gfc_ss_terminator
);
1600 actual
= actual
->next
->next
;
1601 gcc_assert (actual
);
1602 maskexpr
= actual
->expr
;
1605 maskss
= gfc_walk_expr (maskexpr
);
1606 gcc_assert (maskss
!= gfc_ss_terminator
);
1611 /* Initialize the scalarizer. */
1612 gfc_init_loopinfo (&loop
);
1613 gfc_add_ss_to_loop (&loop
, arrayss
);
1615 gfc_add_ss_to_loop (&loop
, maskss
);
1617 /* Initialize the loop. */
1618 gfc_conv_ss_startstride (&loop
);
1619 gfc_conv_loop_setup (&loop
);
1621 gfc_mark_ss_chain_used (arrayss
, 1);
1623 gfc_mark_ss_chain_used (maskss
, 1);
1624 /* Generate the loop body. */
1625 gfc_start_scalarized_body (&loop
, &body
);
1627 /* If we have a mask, only add this element if the mask is set. */
1630 gfc_init_se (&maskse
, NULL
);
1631 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1633 gfc_conv_expr_val (&maskse
, maskexpr
);
1634 gfc_add_block_to_block (&body
, &maskse
.pre
);
1636 gfc_start_block (&block
);
1639 gfc_init_block (&block
);
1641 /* Compare with the current limit. */
1642 gfc_init_se (&arrayse
, NULL
);
1643 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1644 arrayse
.ss
= arrayss
;
1645 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1646 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1648 /* Assign the value to the limit... */
1649 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
1651 /* If it is a more extreme value. */
1652 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1653 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1654 gfc_add_expr_to_block (&block
, tmp
);
1655 gfc_add_block_to_block (&block
, &arrayse
.post
);
1657 tmp
= gfc_finish_block (&block
);
1659 /* We enclose the above in if (mask) {...}. */
1660 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1661 gfc_add_expr_to_block (&body
, tmp
);
1663 gfc_trans_scalarizing_loops (&loop
, &body
);
1665 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1666 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1667 gfc_cleanup_loop (&loop
);
1672 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1674 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
1681 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1682 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1683 arg
= TREE_VALUE (arg
);
1684 type
= TREE_TYPE (arg
);
1686 tmp
= build2 (LSHIFT_EXPR
, type
, convert (type
, integer_one_node
), arg2
);
1687 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
1688 tmp
= fold (build2 (NE_EXPR
, boolean_type_node
, tmp
,
1689 convert (type
, integer_zero_node
)));
1690 type
= gfc_typenode_for_spec (&expr
->ts
);
1691 se
->expr
= convert (type
, tmp
);
1694 /* Generate code to perform the specified operation. */
1696 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
1702 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1703 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1704 arg
= TREE_VALUE (arg
);
1705 type
= TREE_TYPE (arg
);
1707 se
->expr
= fold (build2 (op
, type
, arg
, arg2
));
1712 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
1716 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1717 arg
= TREE_VALUE (arg
);
1719 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
1722 /* Set or clear a single bit. */
1724 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
1732 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1733 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1734 arg
= TREE_VALUE (arg
);
1735 type
= TREE_TYPE (arg
);
1737 tmp
= fold (build2 (LSHIFT_EXPR
, type
,
1738 convert (type
, integer_one_node
), arg2
));
1744 tmp
= fold (build1 (BIT_NOT_EXPR
, type
, tmp
));
1746 se
->expr
= fold (build2 (op
, type
, arg
, tmp
));
1749 /* Extract a sequence of bits.
1750 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1752 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
1761 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1762 arg2
= TREE_CHAIN (arg
);
1763 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
1764 arg
= TREE_VALUE (arg
);
1765 arg2
= TREE_VALUE (arg2
);
1766 type
= TREE_TYPE (arg
);
1768 mask
= build_int_cst (NULL_TREE
, -1);
1769 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
1770 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
1772 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
1774 se
->expr
= fold (build2 (BIT_AND_EXPR
, type
, tmp
, mask
));
1777 /* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift. */
1779 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
1788 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1789 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1790 arg
= TREE_VALUE (arg
);
1791 type
= TREE_TYPE (arg
);
1793 /* Left shift if positive. */
1794 lshift
= build2 (LSHIFT_EXPR
, type
, arg
, arg2
);
1796 /* Right shift if negative. This will perform an arithmetic shift as
1797 we are dealing with signed integers. Section 13.5.7 allows this. */
1798 tmp
= build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
1799 rshift
= build2 (RSHIFT_EXPR
, type
, arg
, tmp
);
1801 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg2
,
1802 convert (TREE_TYPE (arg2
), integer_zero_node
));
1803 rshift
= build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
1805 /* Do nothing if shift == 0. */
1806 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg2
,
1807 convert (TREE_TYPE (arg2
), integer_zero_node
));
1808 se
->expr
= build3 (COND_EXPR
, type
, tmp
, arg
, rshift
);
1811 /* Circular shift. AKA rotate or barrel shift. */
1813 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
1823 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1824 arg2
= TREE_CHAIN (arg
);
1825 arg3
= TREE_CHAIN (arg2
);
1828 /* Use a library function for the 3 parameter version. */
1829 type
= TREE_TYPE (TREE_VALUE (arg
));
1830 /* Convert all args to the same type otherwise we need loads of library
1831 functions. SIZE and SHIFT cannot have values > BIT_SIZE (I) so the
1832 conversion is safe. */
1833 tmp
= convert (type
, TREE_VALUE (arg2
));
1834 TREE_VALUE (arg2
) = tmp
;
1835 tmp
= convert (type
, TREE_VALUE (arg3
));
1836 TREE_VALUE (arg3
) = tmp
;
1838 switch (expr
->ts
.kind
)
1841 tmp
= gfor_fndecl_math_ishftc4
;
1844 tmp
= gfor_fndecl_math_ishftc8
;
1849 se
->expr
= gfc_build_function_call (tmp
, arg
);
1852 arg
= TREE_VALUE (arg
);
1853 arg2
= TREE_VALUE (arg2
);
1854 type
= TREE_TYPE (arg
);
1856 /* Rotate left if positive. */
1857 lrot
= build2 (LROTATE_EXPR
, type
, arg
, arg2
);
1859 /* Rotate right if negative. */
1860 tmp
= build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
1861 rrot
= build2 (RROTATE_EXPR
, type
, arg
, tmp
);
1863 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg2
,
1864 convert (TREE_TYPE (arg2
), integer_zero_node
));
1865 rrot
= build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
1867 /* Do nothing if shift == 0. */
1868 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg2
,
1869 convert (TREE_TYPE (arg2
), integer_zero_node
));
1870 se
->expr
= build3 (COND_EXPR
, type
, tmp
, arg
, rrot
);
1873 /* The length of a character string. */
1875 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
1884 gcc_assert (!se
->ss
);
1886 arg
= expr
->value
.function
.actual
->expr
;
1888 type
= gfc_typenode_for_spec (&expr
->ts
);
1889 switch (arg
->expr_type
)
1892 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
1896 if (arg
->expr_type
== EXPR_VARIABLE
1897 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
1898 && arg
->ref
->type
== REF_ARRAY
)))
1900 /* This doesn't catch all cases.
1901 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1902 and the surrounding thread. */
1903 sym
= arg
->symtree
->n
.sym
;
1904 decl
= gfc_get_symbol_decl (sym
);
1905 if (decl
== current_function_decl
&& sym
->attr
.function
1906 && (sym
->result
== sym
))
1907 decl
= gfc_get_fake_result_decl (sym
);
1909 len
= sym
->ts
.cl
->backend_decl
;
1914 /* Anybody stupid enough to do this deserves inefficient code. */
1915 gfc_init_se (&argse
, se
);
1916 gfc_conv_expr (&argse
, arg
);
1917 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1918 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1919 len
= argse
.string_length
;
1923 se
->expr
= convert (type
, len
);
1926 /* The length of a character string not including trailing blanks. */
1928 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
1933 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1934 type
= gfc_typenode_for_spec (&expr
->ts
);
1935 se
->expr
= gfc_build_function_call (gfor_fndecl_string_len_trim
, args
);
1936 se
->expr
= convert (type
, se
->expr
);
1940 /* Returns the starting position of a substring within a string. */
1943 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
1945 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
1951 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1952 type
= gfc_typenode_for_spec (&expr
->ts
);
1953 tmp
= gfc_advance_chain (args
, 3);
1954 if (TREE_CHAIN (tmp
) == NULL_TREE
)
1956 back
= convert (gfc_logical4_type_node
, integer_one_node
);
1957 back
= tree_cons (NULL_TREE
, integer_zero_node
, NULL_TREE
);
1958 TREE_CHAIN (tmp
) = back
;
1962 back
= TREE_CHAIN (tmp
);
1963 TREE_VALUE (back
) = convert (gfc_logical4_type_node
, TREE_VALUE (back
));
1966 se
->expr
= gfc_build_function_call (gfor_fndecl_string_index
, args
);
1967 se
->expr
= convert (type
, se
->expr
);
1970 /* The ascii value for a single character. */
1972 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
1977 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1978 arg
= TREE_VALUE (TREE_CHAIN (arg
));
1979 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
1980 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
1981 type
= gfc_typenode_for_spec (&expr
->ts
);
1983 se
->expr
= gfc_build_indirect_ref (arg
);
1984 se
->expr
= convert (type
, se
->expr
);
1988 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
1991 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2000 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2001 if (expr
->ts
.type
!= BT_CHARACTER
)
2003 tsource
= TREE_VALUE (arg
);
2004 arg
= TREE_CHAIN (arg
);
2005 fsource
= TREE_VALUE (arg
);
2006 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2010 /* We do the same as in the non-character case, but the argument
2011 list is different because of the string length arguments. We
2012 also have to set the string length for the result. */
2013 len
= TREE_VALUE (arg
);
2014 arg
= TREE_CHAIN (arg
);
2015 tsource
= TREE_VALUE (arg
);
2016 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2017 fsource
= TREE_VALUE (arg
);
2018 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2020 se
->string_length
= len
;
2022 type
= TREE_TYPE (tsource
);
2023 se
->expr
= fold (build3 (COND_EXPR
, type
, mask
, tsource
, fsource
));
2028 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2030 gfc_actual_arglist
*actual
;
2037 gfc_init_se (&argse
, NULL
);
2038 actual
= expr
->value
.function
.actual
;
2040 ss
= gfc_walk_expr (actual
->expr
);
2041 gcc_assert (ss
!= gfc_ss_terminator
);
2042 argse
.want_pointer
= 1;
2043 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2044 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2045 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2046 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2048 actual
= actual
->next
;
2051 gfc_init_se (&argse
, NULL
);
2052 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2053 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2054 args
= gfc_chainon_list (args
, argse
.expr
);
2055 fndecl
= gfor_fndecl_size1
;
2058 fndecl
= gfor_fndecl_size0
;
2060 se
->expr
= gfc_build_function_call (fndecl
, args
);
2061 type
= gfc_typenode_for_spec (&expr
->ts
);
2062 se
->expr
= convert (type
, se
->expr
);
2066 /* Intrinsic string comparison functions. */
2069 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2074 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2075 /* Build a call for the comparison. */
2076 se
->expr
= gfc_build_function_call (gfor_fndecl_compare_string
, args
);
2078 type
= gfc_typenode_for_spec (&expr
->ts
);
2079 se
->expr
= build2 (op
, type
, se
->expr
,
2080 convert (TREE_TYPE (se
->expr
), integer_zero_node
));
2083 /* Generate a call to the adjustl/adjustr library function. */
2085 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2093 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2094 len
= TREE_VALUE (args
);
2096 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2097 var
= gfc_conv_string_tmp (se
, type
, len
);
2098 args
= tree_cons (NULL_TREE
, var
, args
);
2100 tmp
= gfc_build_function_call (fndecl
, args
);
2101 gfc_add_expr_to_block (&se
->pre
, tmp
);
2103 se
->string_length
= len
;
2107 /* Scalar transfer statement.
2108 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2111 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2113 gfc_actual_arglist
*arg
;
2119 gcc_assert (!se
->ss
);
2121 /* Get a pointer to the source. */
2122 arg
= expr
->value
.function
.actual
;
2123 ss
= gfc_walk_expr (arg
->expr
);
2124 gfc_init_se (&argse
, NULL
);
2125 if (ss
== gfc_ss_terminator
)
2126 gfc_conv_expr_reference (&argse
, arg
->expr
);
2128 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2129 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2130 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2134 type
= gfc_typenode_for_spec (&expr
->ts
);
2135 ptr
= convert (build_pointer_type (type
), ptr
);
2136 if (expr
->ts
.type
== BT_CHARACTER
)
2138 gfc_init_se (&argse
, NULL
);
2139 gfc_conv_expr (&argse
, arg
->expr
);
2140 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2141 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2143 se
->string_length
= argse
.string_length
;
2147 se
->expr
= gfc_build_indirect_ref (ptr
);
2152 /* Generate code for the ALLOCATED intrinsic.
2153 Generate inline code that directly check the address of the argument. */
2156 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2158 gfc_actual_arglist
*arg1
;
2163 gfc_init_se (&arg1se
, NULL
);
2164 arg1
= expr
->value
.function
.actual
;
2165 ss1
= gfc_walk_expr (arg1
->expr
);
2166 arg1se
.descriptor_only
= 1;
2167 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2169 tmp
= gfc_conv_descriptor_data (arg1se
.expr
);
2170 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2171 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2172 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2176 /* Generate code for the ASSOCIATED intrinsic.
2177 If both POINTER and TARGET are arrays, generate a call to library function
2178 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2179 In other cases, generate inline code that directly compare the address of
2180 POINTER with the address of TARGET. */
2183 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2185 gfc_actual_arglist
*arg1
;
2186 gfc_actual_arglist
*arg2
;
2194 gfc_init_se (&arg1se
, NULL
);
2195 gfc_init_se (&arg2se
, NULL
);
2196 arg1
= expr
->value
.function
.actual
;
2198 ss1
= gfc_walk_expr (arg1
->expr
);
2202 /* No optional target. */
2203 if (ss1
== gfc_ss_terminator
)
2205 /* A pointer to a scalar. */
2206 arg1se
.want_pointer
= 1;
2207 gfc_conv_expr (&arg1se
, arg1
->expr
);
2212 /* A pointer to an array. */
2213 arg1se
.descriptor_only
= 1;
2214 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2215 tmp2
= gfc_conv_descriptor_data (arg1se
.expr
);
2217 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2218 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2223 /* An optional target. */
2224 ss2
= gfc_walk_expr (arg2
->expr
);
2225 if (ss1
== gfc_ss_terminator
)
2227 /* A pointer to a scalar. */
2228 gcc_assert (ss2
== gfc_ss_terminator
);
2229 arg1se
.want_pointer
= 1;
2230 gfc_conv_expr (&arg1se
, arg1
->expr
);
2231 arg2se
.want_pointer
= 1;
2232 gfc_conv_expr (&arg2se
, arg2
->expr
);
2233 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2238 /* A pointer to an array, call library function _gfor_associated. */
2239 gcc_assert (ss2
!= gfc_ss_terminator
);
2241 arg1se
.want_pointer
= 1;
2242 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2243 args
= gfc_chainon_list (args
, arg1se
.expr
);
2244 arg2se
.want_pointer
= 1;
2245 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2246 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2247 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2248 args
= gfc_chainon_list (args
, arg2se
.expr
);
2249 fndecl
= gfor_fndecl_associated
;
2250 se
->expr
= gfc_build_function_call (fndecl
, args
);
2253 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2257 /* Scan a string for any one of the characters in a set of characters. */
2260 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2262 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2268 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2269 type
= gfc_typenode_for_spec (&expr
->ts
);
2270 tmp
= gfc_advance_chain (args
, 3);
2271 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2273 back
= convert (gfc_logical4_type_node
, integer_one_node
);
2274 back
= tree_cons (NULL_TREE
, integer_zero_node
, NULL_TREE
);
2275 TREE_CHAIN (tmp
) = back
;
2279 back
= TREE_CHAIN (tmp
);
2280 TREE_VALUE (back
) = convert (gfc_logical4_type_node
, TREE_VALUE (back
));
2283 se
->expr
= gfc_build_function_call (gfor_fndecl_string_scan
, args
);
2284 se
->expr
= convert (type
, se
->expr
);
2288 /* Verify that a set of characters contains all the characters in a string
2289 by indentifying the position of the first character in a string of
2290 characters that does not appear in a given set of characters. */
2293 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2295 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2301 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2302 type
= gfc_typenode_for_spec (&expr
->ts
);
2303 tmp
= gfc_advance_chain (args
, 3);
2304 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2306 back
= convert (gfc_logical4_type_node
, integer_one_node
);
2307 back
= tree_cons (NULL_TREE
, integer_zero_node
, NULL_TREE
);
2308 TREE_CHAIN (tmp
) = back
;
2312 back
= TREE_CHAIN (tmp
);
2313 TREE_VALUE (back
) = convert (gfc_logical4_type_node
, TREE_VALUE (back
));
2316 se
->expr
= gfc_build_function_call (gfor_fndecl_string_verify
, args
);
2317 se
->expr
= convert (type
, se
->expr
);
2320 /* Prepare components and related information of a real number which is
2321 the first argument of a elemental functions to manipulate reals. */
2324 void prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2325 real_compnt_info
* rcs
, int all
)
2332 tree exponent
, fraction
;
2336 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2337 gfc_todo_error ("Non-IEEE floating format");
2339 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2341 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2342 arg
= TREE_VALUE (arg
);
2343 rcs
->type
= TREE_TYPE (arg
);
2345 /* Force arg'type to integer by unaffected convert */
2346 a1
= expr
->value
.function
.actual
->expr
;
2347 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2348 rcs
->mtype
= masktype
;
2349 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2350 arg
= gfc_create_var (masktype
, "arg");
2351 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2354 /* Caculate the numbers of bits of exponent, fraction and word */
2355 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2356 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2357 rcs
->fdigits
= convert (masktype
, tmp
);
2358 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2359 wbits
= convert (masktype
, wbits
);
2360 rcs
->edigits
= fold (build2 (MINUS_EXPR
, masktype
, wbits
, tmp
));
2362 /* Form masks for exponent/fraction/sign */
2363 one
= gfc_build_const (masktype
, integer_one_node
);
2364 rcs
->smask
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, wbits
));
2365 rcs
->f1
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
));
2366 rcs
->emask
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
));
2367 rcs
->fmask
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
));
2369 tmp
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
));
2370 tmp
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, tmp
));
2371 rcs
->bias
= fold (build2 (MINUS_EXPR
, masktype
, tmp
,one
));
2375 /* exponent, and fraction */
2376 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2377 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2378 exponent
= gfc_create_var (masktype
, "exponent");
2379 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2380 rcs
->expn
= exponent
;
2382 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2383 fraction
= gfc_create_var (masktype
, "fraction");
2384 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2385 rcs
->frac
= fraction
;
2389 /* Build a call to __builtin_clz. */
2392 call_builtin_clz (tree result_type
, tree op0
)
2394 tree fn
, parms
, call
;
2395 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2397 if (op0_mode
== TYPE_MODE (integer_type_node
))
2398 fn
= built_in_decls
[BUILT_IN_CLZ
];
2399 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2400 fn
= built_in_decls
[BUILT_IN_CLZL
];
2401 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2402 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2406 parms
= tree_cons (NULL
, op0
, NULL
);
2407 call
= gfc_build_function_call (fn
, parms
);
2409 return convert (result_type
, call
);
2412 /* Generate code for SPACING (X) intrinsic function. We generate:
2414 t = expn - (BITS_OF_FRACTION)
2415 res = t << (BITS_OF_FRACTION)
2421 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2428 real_compnt_info rcs
;
2430 prepare_arg_info (se
, expr
, &rcs
, 0);
2432 masktype
= rcs
.mtype
;
2433 fdigits
= rcs
.fdigits
;
2435 zero
= gfc_build_const (masktype
, integer_zero_node
);
2436 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
2437 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2438 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
2439 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
2440 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2441 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
2442 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2447 /* Generate code for RRSPACING (X) intrinsic function. We generate:
2449 if (expn == 0 && frac == 0)
2453 sedigits = edigits + 1;
2456 t1 = leadzero (frac);
2457 frac = frac << (t1 + sedigits);
2458 frac = frac >> (sedigits);
2460 t = bias + BITS_OF_FRACTION_OF;
2461 res = (t << BITS_OF_FRACTION_OF) | frac;
2465 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
2468 tree tmp
, t1
, t2
, cond
, cond2
;
2470 tree fdigits
, fraction
;
2471 real_compnt_info rcs
;
2473 prepare_arg_info (se
, expr
, &rcs
, 1);
2474 masktype
= rcs
.mtype
;
2475 fdigits
= rcs
.fdigits
;
2476 fraction
= rcs
.frac
;
2477 one
= gfc_build_const (masktype
, integer_one_node
);
2478 zero
= gfc_build_const (masktype
, integer_zero_node
);
2479 t2
= build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
);
2481 t1
= call_builtin_clz (masktype
, fraction
);
2482 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
2483 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
2484 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
2485 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
2486 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
2488 tmp
= build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
);
2489 tmp
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2490 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
2492 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
2493 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
2494 tmp
= build3 (COND_EXPR
, masktype
, cond
,
2495 convert (masktype
, integer_zero_node
), tmp
);
2497 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2501 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2504 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
2508 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2509 args
= TREE_VALUE (args
);
2510 args
= gfc_build_addr_expr (NULL
, args
);
2511 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
2512 se
->expr
= gfc_build_function_call (gfor_fndecl_si_kind
, args
);
2515 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2518 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
2520 gfc_actual_arglist
*actual
;
2525 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2527 gfc_init_se (&argse
, se
);
2529 /* Pass a NULL pointer for an absent arg. */
2530 if (actual
->expr
== NULL
)
2531 argse
.expr
= null_pointer_node
;
2533 gfc_conv_expr_reference (&argse
, actual
->expr
);
2535 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2536 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2537 args
= gfc_chainon_list (args
, argse
.expr
);
2539 se
->expr
= gfc_build_function_call (gfor_fndecl_sr_kind
, args
);
2543 /* Generate code for TRIM (A) intrinsic function. */
2546 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
2548 tree gfc_int4_type_node
= gfc_get_int_type (4);
2557 arglist
= NULL_TREE
;
2559 type
= build_pointer_type (gfc_character1_type_node
);
2560 var
= gfc_create_var (type
, "pstr");
2561 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
2562 len
= gfc_create_var (gfc_int4_type_node
, "len");
2564 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
2565 arglist
= gfc_chainon_list (arglist
, gfc_build_addr_expr (NULL
, len
));
2566 arglist
= gfc_chainon_list (arglist
, addr
);
2567 arglist
= chainon (arglist
, tmp
);
2569 tmp
= gfc_build_function_call (gfor_fndecl_string_trim
, arglist
);
2570 gfc_add_expr_to_block (&se
->pre
, tmp
);
2572 /* Free the temporary afterwards, if necessary. */
2573 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
2574 convert (TREE_TYPE (len
), integer_zero_node
));
2575 arglist
= gfc_chainon_list (NULL_TREE
, var
);
2576 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, arglist
);
2577 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2578 gfc_add_expr_to_block (&se
->post
, tmp
);
2581 se
->string_length
= len
;
2585 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2588 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
2590 tree gfc_int4_type_node
= gfc_get_int_type (4);
2599 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2600 len
= TREE_VALUE (args
);
2601 tmp
= gfc_advance_chain (args
, 2);
2602 ncopies
= TREE_VALUE (tmp
);
2603 len
= fold (build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
));
2604 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
2605 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
2607 arglist
= NULL_TREE
;
2608 arglist
= gfc_chainon_list (arglist
, var
);
2609 arglist
= chainon (arglist
, args
);
2610 tmp
= gfc_build_function_call (gfor_fndecl_string_repeat
, arglist
);
2611 gfc_add_expr_to_block (&se
->pre
, tmp
);
2614 se
->string_length
= len
;
2618 /* Generate code for the IARGC intrinsic. If args_only is true this is
2619 actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1. */
2622 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
, bool args_only
)
2628 /* Call the library function. This always returns an INTEGER(4). */
2629 fndecl
= gfor_fndecl_iargc
;
2630 tmp
= gfc_build_function_call (fndecl
, NULL_TREE
);
2632 /* Convert it to the required type. */
2633 type
= gfc_typenode_for_spec (&expr
->ts
);
2634 tmp
= fold_convert (type
, tmp
);
2637 tmp
= build2 (MINUS_EXPR
, type
, tmp
, convert (type
, integer_one_node
));
2641 /* Generate code for an intrinsic function. Some map directly to library
2642 calls, others get special handling. In some cases the name of the function
2643 used depends on the type specifiers. */
2646 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
2648 gfc_intrinsic_sym
*isym
;
2652 isym
= expr
->value
.function
.isym
;
2654 name
= &expr
->value
.function
.name
[2];
2658 lib
= gfc_is_intrinsic_libcall (expr
);
2662 se
->ignore_optional
= 1;
2663 gfc_conv_intrinsic_funcall (se
, expr
);
2668 switch (expr
->value
.function
.isym
->generic_id
)
2673 case GFC_ISYM_REPEAT
:
2674 gfc_conv_intrinsic_repeat (se
, expr
);
2678 gfc_conv_intrinsic_trim (se
, expr
);
2681 case GFC_ISYM_SI_KIND
:
2682 gfc_conv_intrinsic_si_kind (se
, expr
);
2685 case GFC_ISYM_SR_KIND
:
2686 gfc_conv_intrinsic_sr_kind (se
, expr
);
2689 case GFC_ISYM_EXPONENT
:
2690 gfc_conv_intrinsic_exponent (se
, expr
);
2693 case GFC_ISYM_SPACING
:
2694 gfc_conv_intrinsic_spacing (se
, expr
);
2697 case GFC_ISYM_RRSPACING
:
2698 gfc_conv_intrinsic_rrspacing (se
, expr
);
2702 gfc_conv_intrinsic_scan (se
, expr
);
2705 case GFC_ISYM_VERIFY
:
2706 gfc_conv_intrinsic_verify (se
, expr
);
2709 case GFC_ISYM_ALLOCATED
:
2710 gfc_conv_allocated (se
, expr
);
2713 case GFC_ISYM_ASSOCIATED
:
2714 gfc_conv_associated(se
, expr
);
2718 gfc_conv_intrinsic_abs (se
, expr
);
2721 case GFC_ISYM_ADJUSTL
:
2722 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
2725 case GFC_ISYM_ADJUSTR
:
2726 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
2729 case GFC_ISYM_AIMAG
:
2730 gfc_conv_intrinsic_imagpart (se
, expr
);
2734 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
2738 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
2741 case GFC_ISYM_ANINT
:
2742 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
2746 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
2749 case GFC_ISYM_BTEST
:
2750 gfc_conv_intrinsic_btest (se
, expr
);
2753 case GFC_ISYM_ACHAR
:
2755 gfc_conv_intrinsic_char (se
, expr
);
2758 case GFC_ISYM_CONVERSION
:
2760 case GFC_ISYM_LOGICAL
:
2762 gfc_conv_intrinsic_conversion (se
, expr
);
2765 /* Integer conversions are handled seperately to make sure we get the
2766 correct rounding mode. */
2768 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
2772 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
2775 case GFC_ISYM_CEILING
:
2776 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
2779 case GFC_ISYM_FLOOR
:
2780 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
2784 gfc_conv_intrinsic_mod (se
, expr
, 0);
2787 case GFC_ISYM_MODULO
:
2788 gfc_conv_intrinsic_mod (se
, expr
, 1);
2791 case GFC_ISYM_CMPLX
:
2792 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
2795 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
2796 gfc_conv_intrinsic_iargc (se
, expr
, TRUE
);
2799 case GFC_ISYM_CONJG
:
2800 gfc_conv_intrinsic_conjg (se
, expr
);
2803 case GFC_ISYM_COUNT
:
2804 gfc_conv_intrinsic_count (se
, expr
);
2808 gfc_conv_intrinsic_dim (se
, expr
);
2811 case GFC_ISYM_DPROD
:
2812 gfc_conv_intrinsic_dprod (se
, expr
);
2816 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
2819 case GFC_ISYM_IBCLR
:
2820 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
2823 case GFC_ISYM_IBITS
:
2824 gfc_conv_intrinsic_ibits (se
, expr
);
2827 case GFC_ISYM_IBSET
:
2828 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
2831 case GFC_ISYM_IACHAR
:
2832 case GFC_ISYM_ICHAR
:
2833 /* We assume ASCII character sequence. */
2834 gfc_conv_intrinsic_ichar (se
, expr
);
2837 case GFC_ISYM_IARGC
:
2838 gfc_conv_intrinsic_iargc (se
, expr
, FALSE
);
2842 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
2845 case GFC_ISYM_INDEX
:
2846 gfc_conv_intrinsic_index (se
, expr
);
2850 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
2853 case GFC_ISYM_ISHFT
:
2854 gfc_conv_intrinsic_ishft (se
, expr
);
2857 case GFC_ISYM_ISHFTC
:
2858 gfc_conv_intrinsic_ishftc (se
, expr
);
2861 case GFC_ISYM_LBOUND
:
2862 gfc_conv_intrinsic_bound (se
, expr
, 0);
2866 gfc_conv_intrinsic_len (se
, expr
);
2869 case GFC_ISYM_LEN_TRIM
:
2870 gfc_conv_intrinsic_len_trim (se
, expr
);
2874 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
2878 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
2882 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
2886 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
2890 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
2893 case GFC_ISYM_MAXLOC
:
2894 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
2897 case GFC_ISYM_MAXVAL
:
2898 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
2901 case GFC_ISYM_MERGE
:
2902 gfc_conv_intrinsic_merge (se
, expr
);
2906 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
2909 case GFC_ISYM_MINLOC
:
2910 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
2913 case GFC_ISYM_MINVAL
:
2914 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
2918 gfc_conv_intrinsic_not (se
, expr
);
2921 case GFC_ISYM_PRESENT
:
2922 gfc_conv_intrinsic_present (se
, expr
);
2925 case GFC_ISYM_PRODUCT
:
2926 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
2930 gfc_conv_intrinsic_sign (se
, expr
);
2934 gfc_conv_intrinsic_size (se
, expr
);
2938 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
2941 case GFC_ISYM_TRANSFER
:
2942 gfc_conv_intrinsic_transfer (se
, expr
);
2945 case GFC_ISYM_UBOUND
:
2946 gfc_conv_intrinsic_bound (se
, expr
, 1);
2949 case GFC_ISYM_DOT_PRODUCT
:
2950 case GFC_ISYM_MATMUL
:
2951 case GFC_ISYM_IRAND
:
2953 case GFC_ISYM_ETIME
:
2954 case GFC_ISYM_SECOND
:
2955 case GFC_ISYM_GETGID
:
2956 case GFC_ISYM_GETPID
:
2957 case GFC_ISYM_GETUID
:
2958 gfc_conv_intrinsic_funcall (se
, expr
);
2962 gfc_conv_intrinsic_lib_function (se
, expr
);
2968 /* This generates code to execute before entering the scalarization loop.
2969 Currently does nothing. */
2972 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
2974 switch (ss
->expr
->value
.function
.isym
->generic_id
)
2976 case GFC_ISYM_UBOUND
:
2977 case GFC_ISYM_LBOUND
:
2986 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
2987 inside the scalarization loop. */
2990 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
2994 /* The two argument version returns a scalar. */
2995 if (expr
->value
.function
.actual
->next
->expr
)
2998 newss
= gfc_get_ss ();
2999 newss
->type
= GFC_SS_INTRINSIC
;
3007 /* Walk an intrinsic array libcall. */
3010 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3014 gcc_assert (expr
->rank
> 0);
3016 newss
= gfc_get_ss ();
3017 newss
->type
= GFC_SS_FUNCTION
;
3020 newss
->data
.info
.dimen
= expr
->rank
;
3026 /* Returns nonzero if the specified intrinsic function call maps directly to a
3027 an external library call. Should only be used for functions that return
3031 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3033 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3034 gcc_assert (expr
->rank
> 0);
3036 switch (expr
->value
.function
.isym
->generic_id
)
3040 case GFC_ISYM_COUNT
:
3041 case GFC_ISYM_MATMUL
:
3042 case GFC_ISYM_MAXLOC
:
3043 case GFC_ISYM_MAXVAL
:
3044 case GFC_ISYM_MINLOC
:
3045 case GFC_ISYM_MINVAL
:
3046 case GFC_ISYM_PRODUCT
:
3048 case GFC_ISYM_SHAPE
:
3049 case GFC_ISYM_SPREAD
:
3050 case GFC_ISYM_TRANSPOSE
:
3051 /* Ignore absent optional parameters. */
3054 case GFC_ISYM_RESHAPE
:
3055 case GFC_ISYM_CSHIFT
:
3056 case GFC_ISYM_EOSHIFT
:
3058 case GFC_ISYM_UNPACK
:
3059 /* Pass absent optional parameters. */
3067 /* Walk an intrinsic function. */
3069 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3070 gfc_intrinsic_sym
* isym
)
3074 if (isym
->elemental
)
3075 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_SCALAR
);
3077 if (expr
->rank
== 0)
3080 if (gfc_is_intrinsic_libcall (expr
))
3081 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3083 /* Special cases. */
3084 switch (isym
->generic_id
)
3086 case GFC_ISYM_LBOUND
:
3087 case GFC_ISYM_UBOUND
:
3088 return gfc_walk_intrinsic_bound (ss
, expr
);
3091 /* This probably meant someone forgot to add an intrinsic to the above
3092 list(s) when they implemented it, or something's gone horribly wrong.
3094 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3095 expr
->value
.function
.name
);
3099 #include "gt-fortran-trans-intrinsic.h"