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 the number of exponent bits. */
142 tree fdigits
; /* Constant tree of the number of fraction bits. */
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
);
217 /* This is needed because the gcc backend only implements
218 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
219 FLOOR(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 unnecessary 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 i.e. 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) = (abs (shift) >= BIT_SIZE (i))
1779 : ((shift >= 0) ? i << shift : i >> -shift)
1780 where all shifts are logical shifts. */
1782 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
1795 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1796 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1797 arg
= TREE_VALUE (arg
);
1798 type
= TREE_TYPE (arg
);
1799 utype
= gfc_unsigned_type (type
);
1801 /* We convert to an unsigned type because we want a logical shift.
1802 The standard doesn't define the case of shifting negative
1803 numbers, and we try to be compatible with other compilers, most
1804 notably g77, here. */
1805 arg
= convert (utype
, arg
);
1806 width
= fold (build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
));
1808 /* Left shift if positive. */
1809 lshift
= fold (build2 (LSHIFT_EXPR
, type
, arg
, width
));
1811 /* Right shift if negative. */
1812 rshift
= convert (type
, fold (build2 (RSHIFT_EXPR
, utype
, arg
, width
)));
1814 tmp
= fold (build2 (GE_EXPR
, boolean_type_node
, arg2
,
1815 convert (TREE_TYPE (arg2
), integer_zero_node
)));
1816 tmp
= fold (build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
));
1818 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1819 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1821 num_bits
= convert (TREE_TYPE (arg2
),
1822 build_int_cst (NULL
, TYPE_PRECISION (type
)));
1823 cond
= fold (build2 (GE_EXPR
, boolean_type_node
, width
,
1824 convert (TREE_TYPE (arg2
), num_bits
)));
1826 se
->expr
= fold (build3 (COND_EXPR
, type
, cond
,
1827 convert (type
, integer_zero_node
),
1831 /* Circular shift. AKA rotate or barrel shift. */
1833 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
1843 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1844 arg2
= TREE_CHAIN (arg
);
1845 arg3
= TREE_CHAIN (arg2
);
1848 /* Use a library function for the 3 parameter version. */
1849 tree int4type
= gfc_get_int_type (4);
1851 type
= TREE_TYPE (TREE_VALUE (arg
));
1852 /* We convert the first argument to at least 4 bytes, and
1853 convert back afterwards. This removes the need for library
1854 functions for all argument sizes, and function will be
1855 aligned to at least 32 bits, so there's no loss. */
1856 if (expr
->ts
.kind
< 4)
1858 tmp
= convert (int4type
, TREE_VALUE (arg
));
1859 TREE_VALUE (arg
) = tmp
;
1861 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1862 need loads of library functions. They cannot have values >
1863 BIT_SIZE (I) so the conversion is safe. */
1864 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
1865 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
1867 switch (expr
->ts
.kind
)
1872 tmp
= gfor_fndecl_math_ishftc4
;
1875 tmp
= gfor_fndecl_math_ishftc8
;
1880 se
->expr
= gfc_build_function_call (tmp
, arg
);
1881 /* Convert the result back to the original type, if we extended
1882 the first argument's width above. */
1883 if (expr
->ts
.kind
< 4)
1884 se
->expr
= convert (type
, se
->expr
);
1888 arg
= TREE_VALUE (arg
);
1889 arg2
= TREE_VALUE (arg2
);
1890 type
= TREE_TYPE (arg
);
1892 /* Rotate left if positive. */
1893 lrot
= fold (build2 (LROTATE_EXPR
, type
, arg
, arg2
));
1895 /* Rotate right if negative. */
1896 tmp
= fold (build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
));
1897 rrot
= fold (build2 (RROTATE_EXPR
, type
, arg
, tmp
));
1899 tmp
= fold (build2 (GT_EXPR
, boolean_type_node
, arg2
,
1900 convert (TREE_TYPE (arg2
), integer_zero_node
)));
1901 rrot
= fold (build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
));
1903 /* Do nothing if shift == 0. */
1904 tmp
= fold (build2 (EQ_EXPR
, boolean_type_node
, arg2
,
1905 convert (TREE_TYPE (arg2
), integer_zero_node
)));
1906 se
->expr
= fold (build3 (COND_EXPR
, type
, tmp
, arg
, rrot
));
1909 /* The length of a character string. */
1911 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
1920 gcc_assert (!se
->ss
);
1922 arg
= expr
->value
.function
.actual
->expr
;
1924 type
= gfc_typenode_for_spec (&expr
->ts
);
1925 switch (arg
->expr_type
)
1928 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
1932 if (arg
->expr_type
== EXPR_VARIABLE
1933 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
1934 && arg
->ref
->type
== REF_ARRAY
)))
1936 /* This doesn't catch all cases.
1937 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1938 and the surrounding thread. */
1939 sym
= arg
->symtree
->n
.sym
;
1940 decl
= gfc_get_symbol_decl (sym
);
1941 if (decl
== current_function_decl
&& sym
->attr
.function
1942 && (sym
->result
== sym
))
1943 decl
= gfc_get_fake_result_decl (sym
);
1945 len
= sym
->ts
.cl
->backend_decl
;
1950 /* Anybody stupid enough to do this deserves inefficient code. */
1951 gfc_init_se (&argse
, se
);
1952 gfc_conv_expr (&argse
, arg
);
1953 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1954 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1955 len
= argse
.string_length
;
1959 se
->expr
= convert (type
, len
);
1962 /* The length of a character string not including trailing blanks. */
1964 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
1969 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1970 type
= gfc_typenode_for_spec (&expr
->ts
);
1971 se
->expr
= gfc_build_function_call (gfor_fndecl_string_len_trim
, args
);
1972 se
->expr
= convert (type
, se
->expr
);
1976 /* Returns the starting position of a substring within a string. */
1979 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
1981 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
1987 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1988 type
= gfc_typenode_for_spec (&expr
->ts
);
1989 tmp
= gfc_advance_chain (args
, 3);
1990 if (TREE_CHAIN (tmp
) == NULL_TREE
)
1992 back
= convert (gfc_logical4_type_node
, integer_one_node
);
1993 back
= tree_cons (NULL_TREE
, integer_zero_node
, NULL_TREE
);
1994 TREE_CHAIN (tmp
) = back
;
1998 back
= TREE_CHAIN (tmp
);
1999 TREE_VALUE (back
) = convert (gfc_logical4_type_node
, TREE_VALUE (back
));
2002 se
->expr
= gfc_build_function_call (gfor_fndecl_string_index
, args
);
2003 se
->expr
= convert (type
, se
->expr
);
2006 /* The ascii value for a single character. */
2008 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2013 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2014 arg
= TREE_VALUE (TREE_CHAIN (arg
));
2015 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
2016 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
2017 type
= gfc_typenode_for_spec (&expr
->ts
);
2019 se
->expr
= gfc_build_indirect_ref (arg
);
2020 se
->expr
= convert (type
, se
->expr
);
2024 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2027 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2036 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2037 if (expr
->ts
.type
!= BT_CHARACTER
)
2039 tsource
= TREE_VALUE (arg
);
2040 arg
= TREE_CHAIN (arg
);
2041 fsource
= TREE_VALUE (arg
);
2042 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2046 /* We do the same as in the non-character case, but the argument
2047 list is different because of the string length arguments. We
2048 also have to set the string length for the result. */
2049 len
= TREE_VALUE (arg
);
2050 arg
= TREE_CHAIN (arg
);
2051 tsource
= TREE_VALUE (arg
);
2052 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2053 fsource
= TREE_VALUE (arg
);
2054 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2056 se
->string_length
= len
;
2058 type
= TREE_TYPE (tsource
);
2059 se
->expr
= fold (build3 (COND_EXPR
, type
, mask
, tsource
, fsource
));
2064 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2066 gfc_actual_arglist
*actual
;
2073 gfc_init_se (&argse
, NULL
);
2074 actual
= expr
->value
.function
.actual
;
2076 ss
= gfc_walk_expr (actual
->expr
);
2077 gcc_assert (ss
!= gfc_ss_terminator
);
2078 argse
.want_pointer
= 1;
2079 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2080 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2081 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2082 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2084 actual
= actual
->next
;
2087 gfc_init_se (&argse
, NULL
);
2088 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2089 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2090 args
= gfc_chainon_list (args
, argse
.expr
);
2091 fndecl
= gfor_fndecl_size1
;
2094 fndecl
= gfor_fndecl_size0
;
2096 se
->expr
= gfc_build_function_call (fndecl
, args
);
2097 type
= gfc_typenode_for_spec (&expr
->ts
);
2098 se
->expr
= convert (type
, se
->expr
);
2102 /* Intrinsic string comparison functions. */
2105 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2110 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2111 /* Build a call for the comparison. */
2112 se
->expr
= gfc_build_function_call (gfor_fndecl_compare_string
, args
);
2114 type
= gfc_typenode_for_spec (&expr
->ts
);
2115 se
->expr
= build2 (op
, type
, se
->expr
,
2116 convert (TREE_TYPE (se
->expr
), integer_zero_node
));
2119 /* Generate a call to the adjustl/adjustr library function. */
2121 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2129 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2130 len
= TREE_VALUE (args
);
2132 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2133 var
= gfc_conv_string_tmp (se
, type
, len
);
2134 args
= tree_cons (NULL_TREE
, var
, args
);
2136 tmp
= gfc_build_function_call (fndecl
, args
);
2137 gfc_add_expr_to_block (&se
->pre
, tmp
);
2139 se
->string_length
= len
;
2143 /* Scalar transfer statement.
2144 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2147 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2149 gfc_actual_arglist
*arg
;
2155 gcc_assert (!se
->ss
);
2157 /* Get a pointer to the source. */
2158 arg
= expr
->value
.function
.actual
;
2159 ss
= gfc_walk_expr (arg
->expr
);
2160 gfc_init_se (&argse
, NULL
);
2161 if (ss
== gfc_ss_terminator
)
2162 gfc_conv_expr_reference (&argse
, arg
->expr
);
2164 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2165 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2166 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2170 type
= gfc_typenode_for_spec (&expr
->ts
);
2171 ptr
= convert (build_pointer_type (type
), ptr
);
2172 if (expr
->ts
.type
== BT_CHARACTER
)
2174 gfc_init_se (&argse
, NULL
);
2175 gfc_conv_expr (&argse
, arg
->expr
);
2176 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2177 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2179 se
->string_length
= argse
.string_length
;
2183 se
->expr
= gfc_build_indirect_ref (ptr
);
2188 /* Generate code for the ALLOCATED intrinsic.
2189 Generate inline code that directly check the address of the argument. */
2192 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2194 gfc_actual_arglist
*arg1
;
2199 gfc_init_se (&arg1se
, NULL
);
2200 arg1
= expr
->value
.function
.actual
;
2201 ss1
= gfc_walk_expr (arg1
->expr
);
2202 arg1se
.descriptor_only
= 1;
2203 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2205 tmp
= gfc_conv_descriptor_data (arg1se
.expr
);
2206 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2207 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2208 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2212 /* Generate code for the ASSOCIATED intrinsic.
2213 If both POINTER and TARGET are arrays, generate a call to library function
2214 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2215 In other cases, generate inline code that directly compare the address of
2216 POINTER with the address of TARGET. */
2219 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2221 gfc_actual_arglist
*arg1
;
2222 gfc_actual_arglist
*arg2
;
2230 gfc_init_se (&arg1se
, NULL
);
2231 gfc_init_se (&arg2se
, NULL
);
2232 arg1
= expr
->value
.function
.actual
;
2234 ss1
= gfc_walk_expr (arg1
->expr
);
2238 /* No optional target. */
2239 if (ss1
== gfc_ss_terminator
)
2241 /* A pointer to a scalar. */
2242 arg1se
.want_pointer
= 1;
2243 gfc_conv_expr (&arg1se
, arg1
->expr
);
2248 /* A pointer to an array. */
2249 arg1se
.descriptor_only
= 1;
2250 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2251 tmp2
= gfc_conv_descriptor_data (arg1se
.expr
);
2253 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2254 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2259 /* An optional target. */
2260 ss2
= gfc_walk_expr (arg2
->expr
);
2261 if (ss1
== gfc_ss_terminator
)
2263 /* A pointer to a scalar. */
2264 gcc_assert (ss2
== gfc_ss_terminator
);
2265 arg1se
.want_pointer
= 1;
2266 gfc_conv_expr (&arg1se
, arg1
->expr
);
2267 arg2se
.want_pointer
= 1;
2268 gfc_conv_expr (&arg2se
, arg2
->expr
);
2269 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2274 /* A pointer to an array, call library function _gfor_associated. */
2275 gcc_assert (ss2
!= gfc_ss_terminator
);
2277 arg1se
.want_pointer
= 1;
2278 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2279 args
= gfc_chainon_list (args
, arg1se
.expr
);
2280 arg2se
.want_pointer
= 1;
2281 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2282 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2283 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2284 args
= gfc_chainon_list (args
, arg2se
.expr
);
2285 fndecl
= gfor_fndecl_associated
;
2286 se
->expr
= gfc_build_function_call (fndecl
, args
);
2289 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2293 /* Scan a string for any one of the characters in a set of characters. */
2296 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2298 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2304 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2305 type
= gfc_typenode_for_spec (&expr
->ts
);
2306 tmp
= gfc_advance_chain (args
, 3);
2307 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2309 back
= convert (gfc_logical4_type_node
, integer_one_node
);
2310 back
= tree_cons (NULL_TREE
, integer_zero_node
, NULL_TREE
);
2311 TREE_CHAIN (tmp
) = back
;
2315 back
= TREE_CHAIN (tmp
);
2316 TREE_VALUE (back
) = convert (gfc_logical4_type_node
, TREE_VALUE (back
));
2319 se
->expr
= gfc_build_function_call (gfor_fndecl_string_scan
, args
);
2320 se
->expr
= convert (type
, se
->expr
);
2324 /* Verify that a set of characters contains all the characters in a string
2325 by identifying the position of the first character in a string of
2326 characters that does not appear in a given set of characters. */
2329 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2331 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2337 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2338 type
= gfc_typenode_for_spec (&expr
->ts
);
2339 tmp
= gfc_advance_chain (args
, 3);
2340 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2342 back
= convert (gfc_logical4_type_node
, integer_one_node
);
2343 back
= tree_cons (NULL_TREE
, integer_zero_node
, NULL_TREE
);
2344 TREE_CHAIN (tmp
) = back
;
2348 back
= TREE_CHAIN (tmp
);
2349 TREE_VALUE (back
) = convert (gfc_logical4_type_node
, TREE_VALUE (back
));
2352 se
->expr
= gfc_build_function_call (gfor_fndecl_string_verify
, args
);
2353 se
->expr
= convert (type
, se
->expr
);
2356 /* Prepare components and related information of a real number which is
2357 the first argument of a elemental functions to manipulate reals. */
2360 void prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2361 real_compnt_info
* rcs
, int all
)
2368 tree exponent
, fraction
;
2372 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2373 gfc_todo_error ("Non-IEEE floating format");
2375 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2377 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2378 arg
= TREE_VALUE (arg
);
2379 rcs
->type
= TREE_TYPE (arg
);
2381 /* Force arg'type to integer by unaffected convert */
2382 a1
= expr
->value
.function
.actual
->expr
;
2383 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2384 rcs
->mtype
= masktype
;
2385 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2386 arg
= gfc_create_var (masktype
, "arg");
2387 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2390 /* Caculate the numbers of bits of exponent, fraction and word */
2391 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2392 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2393 rcs
->fdigits
= convert (masktype
, tmp
);
2394 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2395 wbits
= convert (masktype
, wbits
);
2396 rcs
->edigits
= fold (build2 (MINUS_EXPR
, masktype
, wbits
, tmp
));
2398 /* Form masks for exponent/fraction/sign */
2399 one
= gfc_build_const (masktype
, integer_one_node
);
2400 rcs
->smask
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, wbits
));
2401 rcs
->f1
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
));
2402 rcs
->emask
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
));
2403 rcs
->fmask
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
));
2405 tmp
= fold (build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
));
2406 tmp
= fold (build2 (LSHIFT_EXPR
, masktype
, one
, tmp
));
2407 rcs
->bias
= fold (build2 (MINUS_EXPR
, masktype
, tmp
,one
));
2411 /* exponent, and fraction */
2412 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2413 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2414 exponent
= gfc_create_var (masktype
, "exponent");
2415 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2416 rcs
->expn
= exponent
;
2418 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2419 fraction
= gfc_create_var (masktype
, "fraction");
2420 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2421 rcs
->frac
= fraction
;
2425 /* Build a call to __builtin_clz. */
2428 call_builtin_clz (tree result_type
, tree op0
)
2430 tree fn
, parms
, call
;
2431 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2433 if (op0_mode
== TYPE_MODE (integer_type_node
))
2434 fn
= built_in_decls
[BUILT_IN_CLZ
];
2435 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2436 fn
= built_in_decls
[BUILT_IN_CLZL
];
2437 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2438 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2442 parms
= tree_cons (NULL
, op0
, NULL
);
2443 call
= gfc_build_function_call (fn
, parms
);
2445 return convert (result_type
, call
);
2449 /* Generate code for SPACING (X) intrinsic function.
2450 SPACING (X) = POW (2, e-p)
2454 t = expn - fdigits // e - p.
2455 res = t << fdigits // Form the exponent. Fraction is zero.
2456 if (t < 0) // The result is out of range. Denormalized case.
2461 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2468 real_compnt_info rcs
;
2470 prepare_arg_info (se
, expr
, &rcs
, 0);
2472 masktype
= rcs
.mtype
;
2473 fdigits
= rcs
.fdigits
;
2475 zero
= gfc_build_const (masktype
, integer_zero_node
);
2476 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
2477 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2478 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
2479 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
2480 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2481 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
2482 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2487 /* Generate code for RRSPACING (X) intrinsic function.
2488 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2490 So the result's exponent is p. And if X is normalized, X's fraction part
2491 is the result's fraction. If X is denormalized, to get the X's fraction we
2492 shift X's fraction part to left until the first '1' is removed.
2496 if (expn == 0 && frac == 0)
2500 // edigits is the number of exponent bits. Add the sign bit.
2501 sedigits = edigits + 1;
2503 if (expn == 0) // Denormalized case.
2505 t1 = leadzero (frac);
2506 frac = frac << (t1 + 1); //Remove the first '1'.
2507 frac = frac >> (sedigits); //Form the fraction.
2510 //fdigits is the number of fraction bits. Form the exponent.
2513 res = (t << fdigits) | frac;
2518 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
2521 tree tmp
, t1
, t2
, cond
, cond2
;
2523 tree fdigits
, fraction
;
2524 real_compnt_info rcs
;
2526 prepare_arg_info (se
, expr
, &rcs
, 1);
2527 masktype
= rcs
.mtype
;
2528 fdigits
= rcs
.fdigits
;
2529 fraction
= rcs
.frac
;
2530 one
= gfc_build_const (masktype
, integer_one_node
);
2531 zero
= gfc_build_const (masktype
, integer_zero_node
);
2532 t2
= fold (build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
));
2534 t1
= call_builtin_clz (masktype
, fraction
);
2535 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
2536 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
2537 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
2538 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
2539 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
2541 tmp
= fold (build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
));
2542 tmp
= fold (build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
));
2543 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
2545 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
2546 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
2547 tmp
= build3 (COND_EXPR
, masktype
, cond
,
2548 convert (masktype
, integer_zero_node
), tmp
);
2550 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2554 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2557 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
2561 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2562 args
= TREE_VALUE (args
);
2563 args
= gfc_build_addr_expr (NULL
, args
);
2564 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
2565 se
->expr
= gfc_build_function_call (gfor_fndecl_si_kind
, args
);
2568 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2571 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
2573 gfc_actual_arglist
*actual
;
2578 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2580 gfc_init_se (&argse
, se
);
2582 /* Pass a NULL pointer for an absent arg. */
2583 if (actual
->expr
== NULL
)
2584 argse
.expr
= null_pointer_node
;
2586 gfc_conv_expr_reference (&argse
, actual
->expr
);
2588 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2589 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2590 args
= gfc_chainon_list (args
, argse
.expr
);
2592 se
->expr
= gfc_build_function_call (gfor_fndecl_sr_kind
, args
);
2596 /* Generate code for TRIM (A) intrinsic function. */
2599 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
2601 tree gfc_int4_type_node
= gfc_get_int_type (4);
2610 arglist
= NULL_TREE
;
2612 type
= build_pointer_type (gfc_character1_type_node
);
2613 var
= gfc_create_var (type
, "pstr");
2614 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
2615 len
= gfc_create_var (gfc_int4_type_node
, "len");
2617 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
2618 arglist
= gfc_chainon_list (arglist
, gfc_build_addr_expr (NULL
, len
));
2619 arglist
= gfc_chainon_list (arglist
, addr
);
2620 arglist
= chainon (arglist
, tmp
);
2622 tmp
= gfc_build_function_call (gfor_fndecl_string_trim
, arglist
);
2623 gfc_add_expr_to_block (&se
->pre
, tmp
);
2625 /* Free the temporary afterwards, if necessary. */
2626 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
2627 convert (TREE_TYPE (len
), integer_zero_node
));
2628 arglist
= gfc_chainon_list (NULL_TREE
, var
);
2629 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, arglist
);
2630 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2631 gfc_add_expr_to_block (&se
->post
, tmp
);
2634 se
->string_length
= len
;
2638 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2641 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
2643 tree gfc_int4_type_node
= gfc_get_int_type (4);
2652 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2653 len
= TREE_VALUE (args
);
2654 tmp
= gfc_advance_chain (args
, 2);
2655 ncopies
= TREE_VALUE (tmp
);
2656 len
= fold (build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
));
2657 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
2658 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
2660 arglist
= NULL_TREE
;
2661 arglist
= gfc_chainon_list (arglist
, var
);
2662 arglist
= chainon (arglist
, args
);
2663 tmp
= gfc_build_function_call (gfor_fndecl_string_repeat
, arglist
);
2664 gfc_add_expr_to_block (&se
->pre
, tmp
);
2667 se
->string_length
= len
;
2671 /* Generate code for the IARGC intrinsic. If args_only is true this is
2672 actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1. */
2675 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
, bool args_only
)
2681 /* Call the library function. This always returns an INTEGER(4). */
2682 fndecl
= gfor_fndecl_iargc
;
2683 tmp
= gfc_build_function_call (fndecl
, NULL_TREE
);
2685 /* Convert it to the required type. */
2686 type
= gfc_typenode_for_spec (&expr
->ts
);
2687 tmp
= fold_convert (type
, tmp
);
2690 tmp
= build2 (MINUS_EXPR
, type
, tmp
, convert (type
, integer_one_node
));
2694 /* Generate code for an intrinsic function. Some map directly to library
2695 calls, others get special handling. In some cases the name of the function
2696 used depends on the type specifiers. */
2699 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
2701 gfc_intrinsic_sym
*isym
;
2705 isym
= expr
->value
.function
.isym
;
2707 name
= &expr
->value
.function
.name
[2];
2711 lib
= gfc_is_intrinsic_libcall (expr
);
2715 se
->ignore_optional
= 1;
2716 gfc_conv_intrinsic_funcall (se
, expr
);
2721 switch (expr
->value
.function
.isym
->generic_id
)
2726 case GFC_ISYM_REPEAT
:
2727 gfc_conv_intrinsic_repeat (se
, expr
);
2731 gfc_conv_intrinsic_trim (se
, expr
);
2734 case GFC_ISYM_SI_KIND
:
2735 gfc_conv_intrinsic_si_kind (se
, expr
);
2738 case GFC_ISYM_SR_KIND
:
2739 gfc_conv_intrinsic_sr_kind (se
, expr
);
2742 case GFC_ISYM_EXPONENT
:
2743 gfc_conv_intrinsic_exponent (se
, expr
);
2746 case GFC_ISYM_SPACING
:
2747 gfc_conv_intrinsic_spacing (se
, expr
);
2750 case GFC_ISYM_RRSPACING
:
2751 gfc_conv_intrinsic_rrspacing (se
, expr
);
2755 gfc_conv_intrinsic_scan (se
, expr
);
2758 case GFC_ISYM_VERIFY
:
2759 gfc_conv_intrinsic_verify (se
, expr
);
2762 case GFC_ISYM_ALLOCATED
:
2763 gfc_conv_allocated (se
, expr
);
2766 case GFC_ISYM_ASSOCIATED
:
2767 gfc_conv_associated(se
, expr
);
2771 gfc_conv_intrinsic_abs (se
, expr
);
2774 case GFC_ISYM_ADJUSTL
:
2775 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
2778 case GFC_ISYM_ADJUSTR
:
2779 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
2782 case GFC_ISYM_AIMAG
:
2783 gfc_conv_intrinsic_imagpart (se
, expr
);
2787 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
2791 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
2794 case GFC_ISYM_ANINT
:
2795 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
2799 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
2802 case GFC_ISYM_BTEST
:
2803 gfc_conv_intrinsic_btest (se
, expr
);
2806 case GFC_ISYM_ACHAR
:
2808 gfc_conv_intrinsic_char (se
, expr
);
2811 case GFC_ISYM_CONVERSION
:
2813 case GFC_ISYM_LOGICAL
:
2815 gfc_conv_intrinsic_conversion (se
, expr
);
2818 /* Integer conversions are handled seperately to make sure we get the
2819 correct rounding mode. */
2821 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
2825 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
2828 case GFC_ISYM_CEILING
:
2829 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
2832 case GFC_ISYM_FLOOR
:
2833 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
2837 gfc_conv_intrinsic_mod (se
, expr
, 0);
2840 case GFC_ISYM_MODULO
:
2841 gfc_conv_intrinsic_mod (se
, expr
, 1);
2844 case GFC_ISYM_CMPLX
:
2845 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
2848 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
2849 gfc_conv_intrinsic_iargc (se
, expr
, TRUE
);
2852 case GFC_ISYM_CONJG
:
2853 gfc_conv_intrinsic_conjg (se
, expr
);
2856 case GFC_ISYM_COUNT
:
2857 gfc_conv_intrinsic_count (se
, expr
);
2861 gfc_conv_intrinsic_dim (se
, expr
);
2864 case GFC_ISYM_DPROD
:
2865 gfc_conv_intrinsic_dprod (se
, expr
);
2869 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
2872 case GFC_ISYM_IBCLR
:
2873 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
2876 case GFC_ISYM_IBITS
:
2877 gfc_conv_intrinsic_ibits (se
, expr
);
2880 case GFC_ISYM_IBSET
:
2881 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
2884 case GFC_ISYM_IACHAR
:
2885 case GFC_ISYM_ICHAR
:
2886 /* We assume ASCII character sequence. */
2887 gfc_conv_intrinsic_ichar (se
, expr
);
2890 case GFC_ISYM_IARGC
:
2891 gfc_conv_intrinsic_iargc (se
, expr
, FALSE
);
2895 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
2898 case GFC_ISYM_INDEX
:
2899 gfc_conv_intrinsic_index (se
, expr
);
2903 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
2906 case GFC_ISYM_ISHFT
:
2907 gfc_conv_intrinsic_ishft (se
, expr
);
2910 case GFC_ISYM_ISHFTC
:
2911 gfc_conv_intrinsic_ishftc (se
, expr
);
2914 case GFC_ISYM_LBOUND
:
2915 gfc_conv_intrinsic_bound (se
, expr
, 0);
2919 gfc_conv_intrinsic_len (se
, expr
);
2922 case GFC_ISYM_LEN_TRIM
:
2923 gfc_conv_intrinsic_len_trim (se
, expr
);
2927 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
2931 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
2935 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
2939 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
2943 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
2946 case GFC_ISYM_MAXLOC
:
2947 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
2950 case GFC_ISYM_MAXVAL
:
2951 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
2954 case GFC_ISYM_MERGE
:
2955 gfc_conv_intrinsic_merge (se
, expr
);
2959 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
2962 case GFC_ISYM_MINLOC
:
2963 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
2966 case GFC_ISYM_MINVAL
:
2967 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
2971 gfc_conv_intrinsic_not (se
, expr
);
2974 case GFC_ISYM_PRESENT
:
2975 gfc_conv_intrinsic_present (se
, expr
);
2978 case GFC_ISYM_PRODUCT
:
2979 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
2983 gfc_conv_intrinsic_sign (se
, expr
);
2987 gfc_conv_intrinsic_size (se
, expr
);
2991 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
2994 case GFC_ISYM_TRANSFER
:
2995 gfc_conv_intrinsic_transfer (se
, expr
);
2998 case GFC_ISYM_UBOUND
:
2999 gfc_conv_intrinsic_bound (se
, expr
, 1);
3002 case GFC_ISYM_DOT_PRODUCT
:
3003 case GFC_ISYM_ETIME
:
3005 case GFC_ISYM_FSTAT
:
3006 case GFC_ISYM_GETCWD
:
3007 case GFC_ISYM_GETGID
:
3008 case GFC_ISYM_GETPID
:
3009 case GFC_ISYM_GETUID
:
3010 case GFC_ISYM_IRAND
:
3011 case GFC_ISYM_MATMUL
:
3013 case GFC_ISYM_SECOND
:
3015 case GFC_ISYM_SYSTEM
:
3016 case GFC_ISYM_UMASK
:
3017 case GFC_ISYM_UNLINK
:
3018 gfc_conv_intrinsic_funcall (se
, expr
);
3022 gfc_conv_intrinsic_lib_function (se
, expr
);
3028 /* This generates code to execute before entering the scalarization loop.
3029 Currently does nothing. */
3032 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3034 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3036 case GFC_ISYM_UBOUND
:
3037 case GFC_ISYM_LBOUND
:
3046 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3047 inside the scalarization loop. */
3050 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3054 /* The two argument version returns a scalar. */
3055 if (expr
->value
.function
.actual
->next
->expr
)
3058 newss
= gfc_get_ss ();
3059 newss
->type
= GFC_SS_INTRINSIC
;
3067 /* Walk an intrinsic array libcall. */
3070 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3074 gcc_assert (expr
->rank
> 0);
3076 newss
= gfc_get_ss ();
3077 newss
->type
= GFC_SS_FUNCTION
;
3080 newss
->data
.info
.dimen
= expr
->rank
;
3086 /* Returns nonzero if the specified intrinsic function call maps directly to a
3087 an external library call. Should only be used for functions that return
3091 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3093 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3094 gcc_assert (expr
->rank
> 0);
3096 switch (expr
->value
.function
.isym
->generic_id
)
3100 case GFC_ISYM_COUNT
:
3101 case GFC_ISYM_MATMUL
:
3102 case GFC_ISYM_MAXLOC
:
3103 case GFC_ISYM_MAXVAL
:
3104 case GFC_ISYM_MINLOC
:
3105 case GFC_ISYM_MINVAL
:
3106 case GFC_ISYM_PRODUCT
:
3108 case GFC_ISYM_SHAPE
:
3109 case GFC_ISYM_SPREAD
:
3110 case GFC_ISYM_TRANSPOSE
:
3111 /* Ignore absent optional parameters. */
3114 case GFC_ISYM_RESHAPE
:
3115 case GFC_ISYM_CSHIFT
:
3116 case GFC_ISYM_EOSHIFT
:
3118 case GFC_ISYM_UNPACK
:
3119 /* Pass absent optional parameters. */
3127 /* Walk an intrinsic function. */
3129 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3130 gfc_intrinsic_sym
* isym
)
3134 if (isym
->elemental
)
3135 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_SCALAR
);
3137 if (expr
->rank
== 0)
3140 if (gfc_is_intrinsic_libcall (expr
))
3141 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3143 /* Special cases. */
3144 switch (isym
->generic_id
)
3146 case GFC_ISYM_LBOUND
:
3147 case GFC_ISYM_UBOUND
:
3148 return gfc_walk_intrinsic_bound (ss
, expr
);
3151 /* This probably meant someone forgot to add an intrinsic to the above
3152 list(s) when they implemented it, or something's gone horribly wrong.
3154 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3155 expr
->value
.function
.name
);
3159 #include "gt-fortran-trans-intrinsic.h"