1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
32 #include "tree-gimple.h"
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct gfc_intrinsic_map_t
GTY(())
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
51 enum gfc_generic_isym_id id
;
53 /* Enum value from the "language-independent", aka C-centric, part
54 of gcc, or END_BUILTINS of no such value set. */
55 /* ??? There are now complex variants in builtins.def, though we
56 don't currently do anything with them. */
57 enum built_in_function code4
;
58 enum built_in_function code8
;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc][48]". */
65 /* True if a complex version of the function exists. */
66 bool complex_available
;
68 /* True if the function should be marked const. */
71 /* The base library name of this function. */
74 /* Cache decls created for the various operand types. */
82 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
83 defines complex variants of all of the entries in mathbuiltins.def
85 #define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
86 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
87 HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
89 #define DEFINE_MATH_BUILTIN(id, name, argtype) \
90 BUILT_IN_FUNCTION (id, name, false)
92 /* TODO: Use builtin function for complex intrinsics. */
93 #define DEFINE_MATH_BUILTIN_C(id, name, argtype) \
94 BUILT_IN_FUNCTION (id, name, true)
96 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
97 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
98 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
100 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
102 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
104 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
106 /* Functions built into gcc itself. */
107 #include "mathbuiltins.def"
109 /* Functions in libm. */
110 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
111 pattern for other mathbuiltins.def entries. At present we have no
112 optimizations for this in the common sources. */
113 LIBM_FUNCTION (SCALE
, "scalbn", false),
115 /* Functions in libgfortran. */
116 LIBF_FUNCTION (FRACTION
, "fraction", false),
117 LIBF_FUNCTION (NEAREST
, "nearest", false),
118 LIBF_FUNCTION (SET_EXPONENT
, "set_exponent", false),
121 LIBF_FUNCTION (NONE
, NULL
, false)
123 #undef DEFINE_MATH_BUILTIN
124 #undef DEFINE_MATH_BUILTIN_C
125 #undef BUILT_IN_FUNCTION
129 /* Structure for storing components of a floating number to be used by
130 elemental functions to manipulate reals. */
133 tree arg
; /* Variable tree to view convert to integer. */
134 tree expn
; /* Variable tree to save exponent. */
135 tree frac
; /* Variable tree to save fraction. */
136 tree smask
; /* Constant tree of sign's mask. */
137 tree emask
; /* Constant tree of exponent's mask. */
138 tree fmask
; /* Constant tree of fraction's mask. */
139 tree edigits
; /* Constant tree of the number of exponent bits. */
140 tree fdigits
; /* Constant tree of the number of fraction bits. */
141 tree f1
; /* Constant tree of the f1 defined in the real model. */
142 tree bias
; /* Constant tree of the bias of exponent in the memory. */
143 tree type
; /* Type tree of arg1. */
144 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
149 /* Evaluate the arguments to an intrinsic function. */
152 gfc_conv_intrinsic_function_args (gfc_se
* se
, gfc_expr
* expr
)
154 gfc_actual_arglist
*actual
;
159 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
161 /* Skip ommitted optional arguments. */
165 /* Evaluate the parameter. This will substitute scalarized
166 references automatically. */
167 gfc_init_se (&argse
, se
);
169 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
171 gfc_conv_expr (&argse
, actual
->expr
);
172 gfc_conv_string_parameter (&argse
);
173 args
= gfc_chainon_list (args
, argse
.string_length
);
176 gfc_conv_expr_val (&argse
, actual
->expr
);
178 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
179 gfc_add_block_to_block (&se
->post
, &argse
.post
);
180 args
= gfc_chainon_list (args
, argse
.expr
);
186 /* Conversions between different types are output by the frontend as
187 intrinsic functions. We implement these directly with inline code. */
190 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
195 /* Evaluate the argument. */
196 type
= gfc_typenode_for_spec (&expr
->ts
);
197 gcc_assert (expr
->value
.function
.actual
->expr
);
198 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
199 arg
= TREE_VALUE (arg
);
201 /* Conversion from complex to non-complex involves taking the real
202 component of the value. */
203 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
204 && expr
->ts
.type
!= BT_COMPLEX
)
208 artype
= TREE_TYPE (TREE_TYPE (arg
));
209 arg
= build1 (REALPART_EXPR
, artype
, arg
);
212 se
->expr
= convert (type
, arg
);
215 /* This is needed because the gcc backend only implements
216 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
217 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
218 Similarly for CEILING. */
221 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
228 argtype
= TREE_TYPE (arg
);
229 arg
= gfc_evaluate_now (arg
, pblock
);
231 intval
= convert (type
, arg
);
232 intval
= gfc_evaluate_now (intval
, pblock
);
234 tmp
= convert (argtype
, intval
);
235 cond
= build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
237 tmp
= build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
238 build_int_cst (type
, 1));
239 tmp
= build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
244 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
245 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
248 build_round_expr (stmtblock_t
* pblock
, tree arg
, tree type
)
257 argtype
= TREE_TYPE (arg
);
258 arg
= gfc_evaluate_now (arg
, pblock
);
260 real_from_string (&r
, "0.5");
261 pos
= build_real (argtype
, r
);
263 real_from_string (&r
, "-0.5");
264 neg
= build_real (argtype
, r
);
266 tmp
= gfc_build_const (argtype
, integer_zero_node
);
267 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
269 tmp
= fold_build3 (COND_EXPR
, argtype
, cond
, pos
, neg
);
270 tmp
= fold_build2 (PLUS_EXPR
, argtype
, arg
, tmp
);
271 return fold_build1 (FIX_TRUNC_EXPR
, type
, tmp
);
275 /* Convert a real to an integer using a specific rounding mode.
276 Ideally we would just build the corresponding GENERIC node,
277 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
280 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int op
)
285 return build_fixbound_expr (pblock
, arg
, type
, 0);
289 return build_fixbound_expr (pblock
, arg
, type
, 1);
293 return build_round_expr (pblock
, arg
, type
);
296 return build1 (op
, type
, arg
);
301 /* Round a real value using the specified rounding mode.
302 We use a temporary integer of that same kind size as the result.
303 Values larger than can be represented by this kind are unchanged, as
304 will not be accurate enough to represent the rounding.
305 huge = HUGE (KIND (a))
306 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
310 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, int op
)
321 kind
= expr
->ts
.kind
;
324 /* We have builtin functions for some cases. */
353 /* Evaluate the argument. */
354 gcc_assert (expr
->value
.function
.actual
->expr
);
355 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
357 /* Use a builtin function if one exists. */
358 if (n
!= END_BUILTINS
)
360 tmp
= built_in_decls
[n
];
361 se
->expr
= gfc_build_function_call (tmp
, arg
);
365 /* This code is probably redundant, but we'll keep it lying around just
367 type
= gfc_typenode_for_spec (&expr
->ts
);
368 arg
= TREE_VALUE (arg
);
369 arg
= gfc_evaluate_now (arg
, &se
->pre
);
371 /* Test if the value is too large to handle sensibly. */
372 gfc_set_model_kind (kind
);
374 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
375 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
376 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
377 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
379 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
380 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
381 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
382 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
383 itype
= gfc_get_int_type (kind
);
385 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
386 tmp
= convert (type
, tmp
);
387 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
392 /* Convert to an integer using the specified rounding mode. */
395 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, int op
)
400 /* Evaluate the argument. */
401 type
= gfc_typenode_for_spec (&expr
->ts
);
402 gcc_assert (expr
->value
.function
.actual
->expr
);
403 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
404 arg
= TREE_VALUE (arg
);
406 if (TREE_CODE (TREE_TYPE (arg
)) == INTEGER_TYPE
)
408 /* Conversion to a different integer kind. */
409 se
->expr
= convert (type
, arg
);
413 /* Conversion from complex to non-complex involves taking the real
414 component of the value. */
415 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
416 && expr
->ts
.type
!= BT_COMPLEX
)
420 artype
= TREE_TYPE (TREE_TYPE (arg
));
421 arg
= build1 (REALPART_EXPR
, artype
, arg
);
424 se
->expr
= build_fix_expr (&se
->pre
, arg
, type
, op
);
429 /* Get the imaginary component of a value. */
432 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
436 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
437 arg
= TREE_VALUE (arg
);
438 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
442 /* Get the complex conjugate of a value. */
445 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
449 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
450 arg
= TREE_VALUE (arg
);
451 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
455 /* Initialize function decls for library functions. The external functions
456 are created as required. Builtin functions are added here. */
459 gfc_build_intrinsic_lib_fndecls (void)
461 gfc_intrinsic_map_t
*m
;
463 /* Add GCC builtin functions. */
464 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
466 if (m
->code4
!= END_BUILTINS
)
467 m
->real4_decl
= built_in_decls
[m
->code4
];
468 if (m
->code8
!= END_BUILTINS
)
469 m
->real8_decl
= built_in_decls
[m
->code8
];
474 /* Create a fndecl for a simple intrinsic library function. */
477 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
482 gfc_actual_arglist
*actual
;
485 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
488 if (ts
->type
== BT_REAL
)
493 pdecl
= &m
->real4_decl
;
496 pdecl
= &m
->real8_decl
;
502 else if (ts
->type
== BT_COMPLEX
)
504 gcc_assert (m
->complex_available
);
509 pdecl
= &m
->complex4_decl
;
512 pdecl
= &m
->complex8_decl
;
526 gcc_assert (ts
->kind
== 4 || ts
->kind
== 8);
527 snprintf (name
, sizeof (name
), "%s%s%s",
528 ts
->type
== BT_COMPLEX
? "c" : "",
530 ts
->kind
== 4 ? "f" : "");
534 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
535 ts
->type
== BT_COMPLEX
? 'c' : 'r',
539 argtypes
= NULL_TREE
;
540 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
542 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
543 argtypes
= gfc_chainon_list (argtypes
, type
);
545 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
546 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
547 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
549 /* Mark the decl as external. */
550 DECL_EXTERNAL (fndecl
) = 1;
551 TREE_PUBLIC (fndecl
) = 1;
553 /* Mark it __attribute__((const)), if possible. */
554 TREE_READONLY (fndecl
) = m
->is_constant
;
556 rest_of_decl_compilation (fndecl
, 1, 0);
563 /* Convert an intrinsic function into an external or builtin call. */
566 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
568 gfc_intrinsic_map_t
*m
;
571 gfc_generic_isym_id id
;
573 id
= expr
->value
.function
.isym
->generic_id
;
574 /* Find the entry for this function. */
575 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
581 if (m
->id
== GFC_ISYM_NONE
)
583 internal_error ("Intrinsic function %s(%d) not recognized",
584 expr
->value
.function
.name
, id
);
587 /* Get the decl and generate the call. */
588 args
= gfc_conv_intrinsic_function_args (se
, expr
);
589 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
590 se
->expr
= gfc_build_function_call (fndecl
, args
);
593 /* Generate code for EXPONENT(X) intrinsic function. */
596 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
601 args
= gfc_conv_intrinsic_function_args (se
, expr
);
603 a1
= expr
->value
.function
.actual
->expr
;
607 fndecl
= gfor_fndecl_math_exponent4
;
610 fndecl
= gfor_fndecl_math_exponent8
;
616 se
->expr
= gfc_build_function_call (fndecl
, args
);
619 /* Evaluate a single upper or lower bound. */
620 /* TODO: bound intrinsic generates way too much unnecessary code. */
623 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
625 gfc_actual_arglist
*arg
;
626 gfc_actual_arglist
*arg2
;
636 gfc_init_se (&argse
, NULL
);
637 arg
= expr
->value
.function
.actual
;
642 /* Create an implicit second parameter from the loop variable. */
643 gcc_assert (!arg2
->expr
);
644 gcc_assert (se
->loop
->dimen
== 1);
645 gcc_assert (se
->ss
->expr
== expr
);
646 gfc_advance_se_ss_chain (se
);
647 bound
= se
->loop
->loopvar
[0];
648 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
653 /* use the passed argument. */
654 gcc_assert (arg
->next
->expr
);
655 gfc_init_se (&argse
, NULL
);
656 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
657 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
659 /* Convert from one based to zero based. */
660 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
664 /* TODO: don't re-evaluate the descriptor on each iteration. */
665 /* Get a descriptor for the first parameter. */
666 ss
= gfc_walk_expr (arg
->expr
);
667 gcc_assert (ss
!= gfc_ss_terminator
);
668 argse
.want_pointer
= 0;
669 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
670 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
671 gfc_add_block_to_block (&se
->post
, &argse
.post
);
675 if (INTEGER_CST_P (bound
))
677 gcc_assert (TREE_INT_CST_HIGH (bound
) == 0);
678 i
= TREE_INT_CST_LOW (bound
);
679 gcc_assert (i
>= 0 && i
< GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)));
683 if (flag_bounds_check
)
685 bound
= gfc_evaluate_now (bound
, &se
->pre
);
686 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
687 bound
, build_int_cst (TREE_TYPE (bound
), 0));
688 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
689 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
690 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
691 gfc_trans_runtime_check (cond
, gfc_strconst_fault
, &se
->pre
);
696 se
->expr
= gfc_conv_descriptor_ubound(desc
, bound
);
698 se
->expr
= gfc_conv_descriptor_lbound(desc
, bound
);
700 type
= gfc_typenode_for_spec (&expr
->ts
);
701 se
->expr
= convert (type
, se
->expr
);
706 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
712 args
= gfc_conv_intrinsic_function_args (se
, expr
);
713 gcc_assert (args
&& TREE_CHAIN (args
) == NULL_TREE
);
714 val
= TREE_VALUE (args
);
716 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
720 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (val
), val
);
724 switch (expr
->ts
.kind
)
735 se
->expr
= fold (gfc_build_function_call (built_in_decls
[n
], args
));
744 /* Create a complex value from one or two real components. */
747 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
754 type
= gfc_typenode_for_spec (&expr
->ts
);
755 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
756 real
= convert (TREE_TYPE (type
), TREE_VALUE (arg
));
758 imag
= convert (TREE_TYPE (type
), TREE_VALUE (TREE_CHAIN (arg
)));
759 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg
))) == COMPLEX_TYPE
)
761 arg
= TREE_VALUE (arg
);
762 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
763 imag
= convert (TREE_TYPE (type
), imag
);
766 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
768 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
771 /* Remainder function MOD(A, P) = A - INT(A / P) * P
772 MODULO(A, P) = A - FLOOR (A / P) * P */
773 /* TODO: MOD(x, 0) */
776 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
788 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
789 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
790 arg
= TREE_VALUE (arg
);
791 type
= TREE_TYPE (arg
);
793 switch (expr
->ts
.type
)
796 /* Integer case is easy, we've got a builtin op. */
798 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, arg
, arg2
);
800 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, arg
, arg2
);
804 /* Real values we have to do the hard way. */
805 arg
= gfc_evaluate_now (arg
, &se
->pre
);
806 arg2
= gfc_evaluate_now (arg2
, &se
->pre
);
808 tmp
= build2 (RDIV_EXPR
, type
, arg
, arg2
);
809 /* Test if the value is too large to handle sensibly. */
810 gfc_set_model_kind (expr
->ts
.kind
);
812 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
813 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
814 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
815 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
817 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
818 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
819 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
820 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
822 itype
= gfc_get_int_type (expr
->ts
.kind
);
824 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_FLOOR_EXPR
);
826 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_TRUNC_EXPR
);
827 tmp
= convert (type
, tmp
);
828 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, arg
);
829 tmp
= build2 (MULT_EXPR
, type
, tmp
, arg2
);
830 se
->expr
= build2 (MINUS_EXPR
, type
, arg
, tmp
);
839 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
842 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
851 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
852 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
853 arg
= TREE_VALUE (arg
);
854 type
= TREE_TYPE (arg
);
856 val
= build2 (MINUS_EXPR
, type
, arg
, arg2
);
857 val
= gfc_evaluate_now (val
, &se
->pre
);
859 zero
= gfc_build_const (type
, integer_zero_node
);
860 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
861 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
865 /* SIGN(A, B) is absolute value of A times sign of B.
866 The real value versions use library functions to ensure the correct
867 handling of negative zero. Integer case implemented as:
868 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
872 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
883 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
884 if (expr
->ts
.type
== BT_REAL
)
886 switch (expr
->ts
.kind
)
889 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
892 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
897 se
->expr
= fold (gfc_build_function_call (tmp
, arg
));
901 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
902 arg
= TREE_VALUE (arg
);
903 type
= TREE_TYPE (arg
);
904 zero
= gfc_build_const (type
, integer_zero_node
);
906 testa
= fold_build2 (GE_EXPR
, boolean_type_node
, arg
, zero
);
907 testb
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
, zero
);
908 tmp
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, testa
, testb
);
909 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
,
910 build1 (NEGATE_EXPR
, type
, arg
), arg
);
914 /* Test for the presence of an optional argument. */
917 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
921 arg
= expr
->value
.function
.actual
->expr
;
922 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
923 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
924 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
928 /* Calculate the double precision product of two single precision values. */
931 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
937 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
938 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
939 arg
= TREE_VALUE (arg
);
941 /* Convert the args to double precision before multiplying. */
942 type
= gfc_typenode_for_spec (&expr
->ts
);
943 arg
= convert (type
, arg
);
944 arg2
= convert (type
, arg2
);
945 se
->expr
= build2 (MULT_EXPR
, type
, arg
, arg2
);
949 /* Return a length one character string containing an ascii character. */
952 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
958 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
959 arg
= TREE_VALUE (arg
);
961 /* We currently don't support character types != 1. */
962 gcc_assert (expr
->ts
.kind
== 1);
963 type
= gfc_character1_type_node
;
964 var
= gfc_create_var (type
, "char");
966 arg
= convert (type
, arg
);
967 gfc_add_modify_expr (&se
->pre
, var
, arg
);
968 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
969 se
->string_length
= integer_one_node
;
973 /* Get the minimum/maximum value of all the parameters.
974 minmax (a1, a2, a3, ...)
987 /* TODO: Mismatching types can occur when specific names are used.
988 These should be handled during resolution. */
990 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1001 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1002 type
= gfc_typenode_for_spec (&expr
->ts
);
1004 limit
= TREE_VALUE (arg
);
1005 if (TREE_TYPE (limit
) != type
)
1006 limit
= convert (type
, limit
);
1007 /* Only evaluate the argument once. */
1008 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1009 limit
= gfc_evaluate_now(limit
, &se
->pre
);
1011 mvar
= gfc_create_var (type
, "M");
1012 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1013 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1015 val
= TREE_VALUE (arg
);
1016 if (TREE_TYPE (val
) != type
)
1017 val
= convert (type
, val
);
1019 /* Only evaluate the argument once. */
1020 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1021 val
= gfc_evaluate_now(val
, &se
->pre
);
1023 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1025 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1026 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1027 gfc_add_expr_to_block (&se
->pre
, tmp
);
1028 elsecase
= build_empty_stmt ();
1035 /* Create a symbol node for this intrinsic. The symbol from the frontend
1036 has the generic name. */
1039 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1043 /* TODO: Add symbols for intrinsic function to the global namespace. */
1044 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1045 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1048 sym
->attr
.external
= 1;
1049 sym
->attr
.function
= 1;
1050 sym
->attr
.always_explicit
= 1;
1051 sym
->attr
.proc
= PROC_INTRINSIC
;
1052 sym
->attr
.flavor
= FL_PROCEDURE
;
1056 sym
->attr
.dimension
= 1;
1057 sym
->as
= gfc_get_array_spec ();
1058 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1059 sym
->as
->rank
= expr
->rank
;
1062 /* TODO: proper argument lists for external intrinsics. */
1066 /* Generate a call to an external intrinsic function. */
1068 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1072 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1075 gcc_assert (expr
->rank
> 0);
1077 gcc_assert (expr
->rank
== 0);
1079 sym
= gfc_get_symbol_for_expr (expr
);
1080 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1084 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1104 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1113 gfc_actual_arglist
*actual
;
1120 gfc_conv_intrinsic_funcall (se
, expr
);
1124 actual
= expr
->value
.function
.actual
;
1125 type
= gfc_typenode_for_spec (&expr
->ts
);
1126 /* Initialize the result. */
1127 resvar
= gfc_create_var (type
, "test");
1129 tmp
= convert (type
, boolean_true_node
);
1131 tmp
= convert (type
, boolean_false_node
);
1132 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1134 /* Walk the arguments. */
1135 arrayss
= gfc_walk_expr (actual
->expr
);
1136 gcc_assert (arrayss
!= gfc_ss_terminator
);
1138 /* Initialize the scalarizer. */
1139 gfc_init_loopinfo (&loop
);
1140 exit_label
= gfc_build_label_decl (NULL_TREE
);
1141 TREE_USED (exit_label
) = 1;
1142 gfc_add_ss_to_loop (&loop
, arrayss
);
1144 /* Initialize the loop. */
1145 gfc_conv_ss_startstride (&loop
);
1146 gfc_conv_loop_setup (&loop
);
1148 gfc_mark_ss_chain_used (arrayss
, 1);
1149 /* Generate the loop body. */
1150 gfc_start_scalarized_body (&loop
, &body
);
1152 /* If the condition matches then set the return value. */
1153 gfc_start_block (&block
);
1155 tmp
= convert (type
, boolean_false_node
);
1157 tmp
= convert (type
, boolean_true_node
);
1158 gfc_add_modify_expr (&block
, resvar
, tmp
);
1160 /* And break out of the loop. */
1161 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1162 gfc_add_expr_to_block (&block
, tmp
);
1164 found
= gfc_finish_block (&block
);
1166 /* Check this element. */
1167 gfc_init_se (&arrayse
, NULL
);
1168 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1169 arrayse
.ss
= arrayss
;
1170 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1172 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1173 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
,
1174 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1175 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1176 gfc_add_expr_to_block (&body
, tmp
);
1177 gfc_add_block_to_block (&body
, &arrayse
.post
);
1179 gfc_trans_scalarizing_loops (&loop
, &body
);
1181 /* Add the exit label. */
1182 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1183 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1185 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1186 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1187 gfc_cleanup_loop (&loop
);
1192 /* COUNT(A) = Number of true elements in A. */
1194 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1201 gfc_actual_arglist
*actual
;
1207 gfc_conv_intrinsic_funcall (se
, expr
);
1211 actual
= expr
->value
.function
.actual
;
1213 type
= gfc_typenode_for_spec (&expr
->ts
);
1214 /* Initialize the result. */
1215 resvar
= gfc_create_var (type
, "count");
1216 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1218 /* Walk the arguments. */
1219 arrayss
= gfc_walk_expr (actual
->expr
);
1220 gcc_assert (arrayss
!= gfc_ss_terminator
);
1222 /* Initialize the scalarizer. */
1223 gfc_init_loopinfo (&loop
);
1224 gfc_add_ss_to_loop (&loop
, arrayss
);
1226 /* Initialize the loop. */
1227 gfc_conv_ss_startstride (&loop
);
1228 gfc_conv_loop_setup (&loop
);
1230 gfc_mark_ss_chain_used (arrayss
, 1);
1231 /* Generate the loop body. */
1232 gfc_start_scalarized_body (&loop
, &body
);
1234 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1235 build_int_cst (TREE_TYPE (resvar
), 1));
1236 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1238 gfc_init_se (&arrayse
, NULL
);
1239 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1240 arrayse
.ss
= arrayss
;
1241 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1242 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1244 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1245 gfc_add_expr_to_block (&body
, tmp
);
1246 gfc_add_block_to_block (&body
, &arrayse
.post
);
1248 gfc_trans_scalarizing_loops (&loop
, &body
);
1250 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1251 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1252 gfc_cleanup_loop (&loop
);
1257 /* Inline implementation of the sum and product intrinsics. */
1259 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1267 gfc_actual_arglist
*actual
;
1272 gfc_expr
*arrayexpr
;
1277 gfc_conv_intrinsic_funcall (se
, expr
);
1281 type
= gfc_typenode_for_spec (&expr
->ts
);
1282 /* Initialize the result. */
1283 resvar
= gfc_create_var (type
, "val");
1284 if (op
== PLUS_EXPR
)
1285 tmp
= gfc_build_const (type
, integer_zero_node
);
1287 tmp
= gfc_build_const (type
, integer_one_node
);
1289 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1291 /* Walk the arguments. */
1292 actual
= expr
->value
.function
.actual
;
1293 arrayexpr
= actual
->expr
;
1294 arrayss
= gfc_walk_expr (arrayexpr
);
1295 gcc_assert (arrayss
!= gfc_ss_terminator
);
1297 actual
= actual
->next
->next
;
1298 gcc_assert (actual
);
1299 maskexpr
= actual
->expr
;
1302 maskss
= gfc_walk_expr (maskexpr
);
1303 gcc_assert (maskss
!= gfc_ss_terminator
);
1308 /* Initialize the scalarizer. */
1309 gfc_init_loopinfo (&loop
);
1310 gfc_add_ss_to_loop (&loop
, arrayss
);
1312 gfc_add_ss_to_loop (&loop
, maskss
);
1314 /* Initialize the loop. */
1315 gfc_conv_ss_startstride (&loop
);
1316 gfc_conv_loop_setup (&loop
);
1318 gfc_mark_ss_chain_used (arrayss
, 1);
1320 gfc_mark_ss_chain_used (maskss
, 1);
1321 /* Generate the loop body. */
1322 gfc_start_scalarized_body (&loop
, &body
);
1324 /* If we have a mask, only add this element if the mask is set. */
1327 gfc_init_se (&maskse
, NULL
);
1328 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1330 gfc_conv_expr_val (&maskse
, maskexpr
);
1331 gfc_add_block_to_block (&body
, &maskse
.pre
);
1333 gfc_start_block (&block
);
1336 gfc_init_block (&block
);
1338 /* Do the actual summation/product. */
1339 gfc_init_se (&arrayse
, NULL
);
1340 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1341 arrayse
.ss
= arrayss
;
1342 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1343 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1345 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1346 gfc_add_modify_expr (&block
, resvar
, tmp
);
1347 gfc_add_block_to_block (&block
, &arrayse
.post
);
1351 /* We enclose the above in if (mask) {...} . */
1352 tmp
= gfc_finish_block (&block
);
1354 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1357 tmp
= gfc_finish_block (&block
);
1358 gfc_add_expr_to_block (&body
, tmp
);
1360 gfc_trans_scalarizing_loops (&loop
, &body
);
1361 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1362 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1363 gfc_cleanup_loop (&loop
);
1369 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1373 stmtblock_t ifblock
;
1380 gfc_actual_arglist
*actual
;
1385 gfc_expr
*arrayexpr
;
1392 gfc_conv_intrinsic_funcall (se
, expr
);
1396 /* Initialize the result. */
1397 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1398 type
= gfc_typenode_for_spec (&expr
->ts
);
1400 /* Walk the arguments. */
1401 actual
= expr
->value
.function
.actual
;
1402 arrayexpr
= actual
->expr
;
1403 arrayss
= gfc_walk_expr (arrayexpr
);
1404 gcc_assert (arrayss
!= gfc_ss_terminator
);
1406 actual
= actual
->next
->next
;
1407 gcc_assert (actual
);
1408 maskexpr
= actual
->expr
;
1411 maskss
= gfc_walk_expr (maskexpr
);
1412 gcc_assert (maskss
!= gfc_ss_terminator
);
1417 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1418 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1419 switch (arrayexpr
->ts
.type
)
1422 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1426 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1427 arrayexpr
->ts
.kind
);
1434 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1436 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1437 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1439 /* Initialize the scalarizer. */
1440 gfc_init_loopinfo (&loop
);
1441 gfc_add_ss_to_loop (&loop
, arrayss
);
1443 gfc_add_ss_to_loop (&loop
, maskss
);
1445 /* Initialize the loop. */
1446 gfc_conv_ss_startstride (&loop
);
1447 gfc_conv_loop_setup (&loop
);
1449 gcc_assert (loop
.dimen
== 1);
1451 /* Initialize the position to the first element. If the array has zero
1452 size we need to return zero. Otherwise use the first element of the
1453 array, in case all elements are equal to the limit.
1454 i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1455 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1456 loop
.from
[0], gfc_index_one_node
);
1457 cond
= fold_build2 (GE_EXPR
, boolean_type_node
,
1458 loop
.to
[0], loop
.from
[0]);
1459 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
1461 gfc_add_modify_expr (&loop
.pre
, pos
, tmp
);
1463 gfc_mark_ss_chain_used (arrayss
, 1);
1465 gfc_mark_ss_chain_used (maskss
, 1);
1466 /* Generate the loop body. */
1467 gfc_start_scalarized_body (&loop
, &body
);
1469 /* If we have a mask, only check this element if the mask is set. */
1472 gfc_init_se (&maskse
, NULL
);
1473 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1475 gfc_conv_expr_val (&maskse
, maskexpr
);
1476 gfc_add_block_to_block (&body
, &maskse
.pre
);
1478 gfc_start_block (&block
);
1481 gfc_init_block (&block
);
1483 /* Compare with the current limit. */
1484 gfc_init_se (&arrayse
, NULL
);
1485 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1486 arrayse
.ss
= arrayss
;
1487 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1488 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1490 /* We do the following if this is a more extreme value. */
1491 gfc_start_block (&ifblock
);
1493 /* Assign the value to the limit... */
1494 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
1496 /* Remember where we are. */
1497 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
1499 ifbody
= gfc_finish_block (&ifblock
);
1501 /* If it is a more extreme value. */
1502 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1503 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1504 gfc_add_expr_to_block (&block
, tmp
);
1508 /* We enclose the above in if (mask) {...}. */
1509 tmp
= gfc_finish_block (&block
);
1511 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1514 tmp
= gfc_finish_block (&block
);
1515 gfc_add_expr_to_block (&body
, tmp
);
1517 gfc_trans_scalarizing_loops (&loop
, &body
);
1519 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1520 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1521 gfc_cleanup_loop (&loop
);
1523 /* Return a value in the range 1..SIZE(array). */
1524 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
1525 gfc_index_one_node
);
1526 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
);
1527 /* And convert to the required type. */
1528 se
->expr
= convert (type
, tmp
);
1532 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
1541 gfc_actual_arglist
*actual
;
1546 gfc_expr
*arrayexpr
;
1552 gfc_conv_intrinsic_funcall (se
, expr
);
1556 type
= gfc_typenode_for_spec (&expr
->ts
);
1557 /* Initialize the result. */
1558 limit
= gfc_create_var (type
, "limit");
1559 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
1560 switch (expr
->ts
.type
)
1563 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
1567 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
1574 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1576 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1577 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1579 /* Walk the arguments. */
1580 actual
= expr
->value
.function
.actual
;
1581 arrayexpr
= actual
->expr
;
1582 arrayss
= gfc_walk_expr (arrayexpr
);
1583 gcc_assert (arrayss
!= gfc_ss_terminator
);
1585 actual
= actual
->next
->next
;
1586 gcc_assert (actual
);
1587 maskexpr
= actual
->expr
;
1590 maskss
= gfc_walk_expr (maskexpr
);
1591 gcc_assert (maskss
!= gfc_ss_terminator
);
1596 /* Initialize the scalarizer. */
1597 gfc_init_loopinfo (&loop
);
1598 gfc_add_ss_to_loop (&loop
, arrayss
);
1600 gfc_add_ss_to_loop (&loop
, maskss
);
1602 /* Initialize the loop. */
1603 gfc_conv_ss_startstride (&loop
);
1604 gfc_conv_loop_setup (&loop
);
1606 gfc_mark_ss_chain_used (arrayss
, 1);
1608 gfc_mark_ss_chain_used (maskss
, 1);
1609 /* Generate the loop body. */
1610 gfc_start_scalarized_body (&loop
, &body
);
1612 /* If we have a mask, only add this element if the mask is set. */
1615 gfc_init_se (&maskse
, NULL
);
1616 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1618 gfc_conv_expr_val (&maskse
, maskexpr
);
1619 gfc_add_block_to_block (&body
, &maskse
.pre
);
1621 gfc_start_block (&block
);
1624 gfc_init_block (&block
);
1626 /* Compare with the current limit. */
1627 gfc_init_se (&arrayse
, NULL
);
1628 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1629 arrayse
.ss
= arrayss
;
1630 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1631 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1633 /* Assign the value to the limit... */
1634 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
1636 /* If it is a more extreme value. */
1637 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1638 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1639 gfc_add_expr_to_block (&block
, tmp
);
1640 gfc_add_block_to_block (&block
, &arrayse
.post
);
1642 tmp
= gfc_finish_block (&block
);
1644 /* We enclose the above in if (mask) {...}. */
1645 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1646 gfc_add_expr_to_block (&body
, tmp
);
1648 gfc_trans_scalarizing_loops (&loop
, &body
);
1650 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1651 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1652 gfc_cleanup_loop (&loop
);
1657 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1659 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
1666 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1667 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1668 arg
= TREE_VALUE (arg
);
1669 type
= TREE_TYPE (arg
);
1671 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1672 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
1673 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
1674 build_int_cst (type
, 0));
1675 type
= gfc_typenode_for_spec (&expr
->ts
);
1676 se
->expr
= convert (type
, tmp
);
1679 /* Generate code to perform the specified operation. */
1681 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
1687 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1688 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1689 arg
= TREE_VALUE (arg
);
1690 type
= TREE_TYPE (arg
);
1692 se
->expr
= fold_build2 (op
, type
, arg
, arg2
);
1697 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
1701 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1702 arg
= TREE_VALUE (arg
);
1704 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
1707 /* Set or clear a single bit. */
1709 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
1717 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1718 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1719 arg
= TREE_VALUE (arg
);
1720 type
= TREE_TYPE (arg
);
1722 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
1728 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
1730 se
->expr
= fold_build2 (op
, type
, arg
, tmp
);
1733 /* Extract a sequence of bits.
1734 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1736 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
1745 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1746 arg2
= TREE_CHAIN (arg
);
1747 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
1748 arg
= TREE_VALUE (arg
);
1749 arg2
= TREE_VALUE (arg2
);
1750 type
= TREE_TYPE (arg
);
1752 mask
= build_int_cst (NULL_TREE
, -1);
1753 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
1754 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
1756 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
1758 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
1761 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1763 : ((shift >= 0) ? i << shift : i >> -shift)
1764 where all shifts are logical shifts. */
1766 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
1779 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1780 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1781 arg
= TREE_VALUE (arg
);
1782 type
= TREE_TYPE (arg
);
1783 utype
= gfc_unsigned_type (type
);
1785 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
);
1787 /* Left shift if positive. */
1788 lshift
= fold_build2 (LSHIFT_EXPR
, type
, arg
, width
);
1790 /* Right shift if negative.
1791 We convert to an unsigned type because we want a logical shift.
1792 The standard doesn't define the case of shifting negative
1793 numbers, and we try to be compatible with other compilers, most
1794 notably g77, here. */
1795 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
1796 convert (utype
, arg
), width
));
1798 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
,
1799 build_int_cst (TREE_TYPE (arg2
), 0));
1800 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
1802 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1803 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1805 num_bits
= build_int_cst (TREE_TYPE (arg2
), TYPE_PRECISION (type
));
1806 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
1808 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
1809 build_int_cst (type
, 0), tmp
);
1812 /* Circular shift. AKA rotate or barrel shift. */
1814 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
1825 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1826 arg2
= TREE_CHAIN (arg
);
1827 arg3
= TREE_CHAIN (arg2
);
1830 /* Use a library function for the 3 parameter version. */
1831 tree int4type
= gfc_get_int_type (4);
1833 type
= TREE_TYPE (TREE_VALUE (arg
));
1834 /* We convert the first argument to at least 4 bytes, and
1835 convert back afterwards. This removes the need for library
1836 functions for all argument sizes, and function will be
1837 aligned to at least 32 bits, so there's no loss. */
1838 if (expr
->ts
.kind
< 4)
1840 tmp
= convert (int4type
, TREE_VALUE (arg
));
1841 TREE_VALUE (arg
) = tmp
;
1843 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1844 need loads of library functions. They cannot have values >
1845 BIT_SIZE (I) so the conversion is safe. */
1846 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
1847 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
1849 switch (expr
->ts
.kind
)
1854 tmp
= gfor_fndecl_math_ishftc4
;
1857 tmp
= gfor_fndecl_math_ishftc8
;
1862 se
->expr
= gfc_build_function_call (tmp
, arg
);
1863 /* Convert the result back to the original type, if we extended
1864 the first argument's width above. */
1865 if (expr
->ts
.kind
< 4)
1866 se
->expr
= convert (type
, se
->expr
);
1870 arg
= TREE_VALUE (arg
);
1871 arg2
= TREE_VALUE (arg2
);
1872 type
= TREE_TYPE (arg
);
1874 /* Rotate left if positive. */
1875 lrot
= fold_build2 (LROTATE_EXPR
, type
, arg
, arg2
);
1877 /* Rotate right if negative. */
1878 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
1879 rrot
= fold_build2 (RROTATE_EXPR
, type
, arg
, tmp
);
1881 zero
= build_int_cst (TREE_TYPE (arg2
), 0);
1882 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
);
1883 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
1885 /* Do nothing if shift == 0. */
1886 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg2
, zero
);
1887 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, arg
, rrot
);
1890 /* The length of a character string. */
1892 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
1901 gcc_assert (!se
->ss
);
1903 arg
= expr
->value
.function
.actual
->expr
;
1905 type
= gfc_typenode_for_spec (&expr
->ts
);
1906 switch (arg
->expr_type
)
1909 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
1913 if (arg
->expr_type
== EXPR_VARIABLE
1914 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
1915 && arg
->ref
->type
== REF_ARRAY
)))
1917 /* This doesn't catch all cases.
1918 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1919 and the surrounding thread. */
1920 sym
= arg
->symtree
->n
.sym
;
1921 decl
= gfc_get_symbol_decl (sym
);
1922 if (decl
== current_function_decl
&& sym
->attr
.function
1923 && (sym
->result
== sym
))
1924 decl
= gfc_get_fake_result_decl (sym
);
1926 len
= sym
->ts
.cl
->backend_decl
;
1931 /* Anybody stupid enough to do this deserves inefficient code. */
1932 gfc_init_se (&argse
, se
);
1933 gfc_conv_expr (&argse
, arg
);
1934 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1935 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1936 len
= argse
.string_length
;
1940 se
->expr
= convert (type
, len
);
1943 /* The length of a character string not including trailing blanks. */
1945 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
1950 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1951 type
= gfc_typenode_for_spec (&expr
->ts
);
1952 se
->expr
= gfc_build_function_call (gfor_fndecl_string_len_trim
, args
);
1953 se
->expr
= convert (type
, se
->expr
);
1957 /* Returns the starting position of a substring within a string. */
1960 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
1962 tree logical4_type_node
= gfc_get_logical_type (4);
1968 args
= gfc_conv_intrinsic_function_args (se
, expr
);
1969 type
= gfc_typenode_for_spec (&expr
->ts
);
1970 tmp
= gfc_advance_chain (args
, 3);
1971 if (TREE_CHAIN (tmp
) == NULL_TREE
)
1973 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
1975 TREE_CHAIN (tmp
) = back
;
1979 back
= TREE_CHAIN (tmp
);
1980 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
1983 se
->expr
= gfc_build_function_call (gfor_fndecl_string_index
, args
);
1984 se
->expr
= convert (type
, se
->expr
);
1987 /* The ascii value for a single character. */
1989 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
1994 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1995 arg
= TREE_VALUE (TREE_CHAIN (arg
));
1996 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
1997 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
1998 type
= gfc_typenode_for_spec (&expr
->ts
);
2000 se
->expr
= gfc_build_indirect_ref (arg
);
2001 se
->expr
= convert (type
, se
->expr
);
2005 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2008 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2017 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2018 if (expr
->ts
.type
!= BT_CHARACTER
)
2020 tsource
= TREE_VALUE (arg
);
2021 arg
= TREE_CHAIN (arg
);
2022 fsource
= TREE_VALUE (arg
);
2023 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2027 /* We do the same as in the non-character case, but the argument
2028 list is different because of the string length arguments. We
2029 also have to set the string length for the result. */
2030 len
= TREE_VALUE (arg
);
2031 arg
= TREE_CHAIN (arg
);
2032 tsource
= TREE_VALUE (arg
);
2033 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2034 fsource
= TREE_VALUE (arg
);
2035 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2037 se
->string_length
= len
;
2039 type
= TREE_TYPE (tsource
);
2040 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2045 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2047 gfc_actual_arglist
*actual
;
2054 gfc_init_se (&argse
, NULL
);
2055 actual
= expr
->value
.function
.actual
;
2057 ss
= gfc_walk_expr (actual
->expr
);
2058 gcc_assert (ss
!= gfc_ss_terminator
);
2059 argse
.want_pointer
= 1;
2060 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2061 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2062 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2063 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2065 actual
= actual
->next
;
2068 gfc_init_se (&argse
, NULL
);
2069 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2070 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2071 args
= gfc_chainon_list (args
, argse
.expr
);
2072 fndecl
= gfor_fndecl_size1
;
2075 fndecl
= gfor_fndecl_size0
;
2077 se
->expr
= gfc_build_function_call (fndecl
, args
);
2078 type
= gfc_typenode_for_spec (&expr
->ts
);
2079 se
->expr
= convert (type
, se
->expr
);
2083 /* Intrinsic string comparison functions. */
2086 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2091 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2092 /* Build a call for the comparison. */
2093 se
->expr
= gfc_build_function_call (gfor_fndecl_compare_string
, args
);
2095 type
= gfc_typenode_for_spec (&expr
->ts
);
2096 se
->expr
= build2 (op
, type
, se
->expr
,
2097 build_int_cst (TREE_TYPE (se
->expr
), 0));
2100 /* Generate a call to the adjustl/adjustr library function. */
2102 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2110 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2111 len
= TREE_VALUE (args
);
2113 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2114 var
= gfc_conv_string_tmp (se
, type
, len
);
2115 args
= tree_cons (NULL_TREE
, var
, args
);
2117 tmp
= gfc_build_function_call (fndecl
, args
);
2118 gfc_add_expr_to_block (&se
->pre
, tmp
);
2120 se
->string_length
= len
;
2124 /* Scalar transfer statement.
2125 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2128 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2130 gfc_actual_arglist
*arg
;
2136 gcc_assert (!se
->ss
);
2138 /* Get a pointer to the source. */
2139 arg
= expr
->value
.function
.actual
;
2140 ss
= gfc_walk_expr (arg
->expr
);
2141 gfc_init_se (&argse
, NULL
);
2142 if (ss
== gfc_ss_terminator
)
2143 gfc_conv_expr_reference (&argse
, arg
->expr
);
2145 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2146 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2147 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2151 type
= gfc_typenode_for_spec (&expr
->ts
);
2152 ptr
= convert (build_pointer_type (type
), ptr
);
2153 if (expr
->ts
.type
== BT_CHARACTER
)
2155 gfc_init_se (&argse
, NULL
);
2156 gfc_conv_expr (&argse
, arg
->expr
);
2157 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2158 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2160 se
->string_length
= argse
.string_length
;
2164 se
->expr
= gfc_build_indirect_ref (ptr
);
2169 /* Generate code for the ALLOCATED intrinsic.
2170 Generate inline code that directly check the address of the argument. */
2173 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2175 gfc_actual_arglist
*arg1
;
2180 gfc_init_se (&arg1se
, NULL
);
2181 arg1
= expr
->value
.function
.actual
;
2182 ss1
= gfc_walk_expr (arg1
->expr
);
2183 arg1se
.descriptor_only
= 1;
2184 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2186 tmp
= gfc_conv_descriptor_data (arg1se
.expr
);
2187 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2188 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2189 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2193 /* Generate code for the ASSOCIATED intrinsic.
2194 If both POINTER and TARGET are arrays, generate a call to library function
2195 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2196 In other cases, generate inline code that directly compare the address of
2197 POINTER with the address of TARGET. */
2200 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2202 gfc_actual_arglist
*arg1
;
2203 gfc_actual_arglist
*arg2
;
2211 gfc_init_se (&arg1se
, NULL
);
2212 gfc_init_se (&arg2se
, NULL
);
2213 arg1
= expr
->value
.function
.actual
;
2215 ss1
= gfc_walk_expr (arg1
->expr
);
2219 /* No optional target. */
2220 if (ss1
== gfc_ss_terminator
)
2222 /* A pointer to a scalar. */
2223 arg1se
.want_pointer
= 1;
2224 gfc_conv_expr (&arg1se
, arg1
->expr
);
2229 /* A pointer to an array. */
2230 arg1se
.descriptor_only
= 1;
2231 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2232 tmp2
= gfc_conv_descriptor_data (arg1se
.expr
);
2234 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2235 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2240 /* An optional target. */
2241 ss2
= gfc_walk_expr (arg2
->expr
);
2242 if (ss1
== gfc_ss_terminator
)
2244 /* A pointer to a scalar. */
2245 gcc_assert (ss2
== gfc_ss_terminator
);
2246 arg1se
.want_pointer
= 1;
2247 gfc_conv_expr (&arg1se
, arg1
->expr
);
2248 arg2se
.want_pointer
= 1;
2249 gfc_conv_expr (&arg2se
, arg2
->expr
);
2250 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2255 /* A pointer to an array, call library function _gfor_associated. */
2256 gcc_assert (ss2
!= gfc_ss_terminator
);
2258 arg1se
.want_pointer
= 1;
2259 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2260 args
= gfc_chainon_list (args
, arg1se
.expr
);
2261 arg2se
.want_pointer
= 1;
2262 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2263 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2264 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2265 args
= gfc_chainon_list (args
, arg2se
.expr
);
2266 fndecl
= gfor_fndecl_associated
;
2267 se
->expr
= gfc_build_function_call (fndecl
, args
);
2270 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2274 /* Scan a string for any one of the characters in a set of characters. */
2277 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2279 tree logical4_type_node
= gfc_get_logical_type (4);
2285 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2286 type
= gfc_typenode_for_spec (&expr
->ts
);
2287 tmp
= gfc_advance_chain (args
, 3);
2288 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2290 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2292 TREE_CHAIN (tmp
) = back
;
2296 back
= TREE_CHAIN (tmp
);
2297 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2300 se
->expr
= gfc_build_function_call (gfor_fndecl_string_scan
, args
);
2301 se
->expr
= convert (type
, se
->expr
);
2305 /* Verify that a set of characters contains all the characters in a string
2306 by identifying the position of the first character in a string of
2307 characters that does not appear in a given set of characters. */
2310 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2312 tree logical4_type_node
= gfc_get_logical_type (4);
2318 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2319 type
= gfc_typenode_for_spec (&expr
->ts
);
2320 tmp
= gfc_advance_chain (args
, 3);
2321 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2323 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2325 TREE_CHAIN (tmp
) = back
;
2329 back
= TREE_CHAIN (tmp
);
2330 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2333 se
->expr
= gfc_build_function_call (gfor_fndecl_string_verify
, args
);
2334 se
->expr
= convert (type
, se
->expr
);
2337 /* Prepare components and related information of a real number which is
2338 the first argument of a elemental functions to manipulate reals. */
2341 prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2342 real_compnt_info
* rcs
, int all
)
2349 tree exponent
, fraction
;
2353 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2354 gfc_todo_error ("Non-IEEE floating format");
2356 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2358 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2359 arg
= TREE_VALUE (arg
);
2360 rcs
->type
= TREE_TYPE (arg
);
2362 /* Force arg'type to integer by unaffected convert */
2363 a1
= expr
->value
.function
.actual
->expr
;
2364 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2365 rcs
->mtype
= masktype
;
2366 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2367 arg
= gfc_create_var (masktype
, "arg");
2368 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2371 /* Calculate the numbers of bits of exponent, fraction and word */
2372 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2373 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2374 rcs
->fdigits
= convert (masktype
, tmp
);
2375 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2376 wbits
= convert (masktype
, wbits
);
2377 rcs
->edigits
= fold_build2 (MINUS_EXPR
, masktype
, wbits
, tmp
);
2379 /* Form masks for exponent/fraction/sign */
2380 one
= gfc_build_const (masktype
, integer_one_node
);
2381 rcs
->smask
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, wbits
);
2382 rcs
->f1
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
);
2383 rcs
->emask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
);
2384 rcs
->fmask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
);
2386 tmp
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
);
2387 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, tmp
);
2388 rcs
->bias
= fold_build2 (MINUS_EXPR
, masktype
, tmp
,one
);
2392 /* exponent, and fraction */
2393 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2394 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2395 exponent
= gfc_create_var (masktype
, "exponent");
2396 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2397 rcs
->expn
= exponent
;
2399 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2400 fraction
= gfc_create_var (masktype
, "fraction");
2401 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2402 rcs
->frac
= fraction
;
2406 /* Build a call to __builtin_clz. */
2409 call_builtin_clz (tree result_type
, tree op0
)
2411 tree fn
, parms
, call
;
2412 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2414 if (op0_mode
== TYPE_MODE (integer_type_node
))
2415 fn
= built_in_decls
[BUILT_IN_CLZ
];
2416 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2417 fn
= built_in_decls
[BUILT_IN_CLZL
];
2418 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2419 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2423 parms
= tree_cons (NULL
, op0
, NULL
);
2424 call
= gfc_build_function_call (fn
, parms
);
2426 return convert (result_type
, call
);
2430 /* Generate code for SPACING (X) intrinsic function.
2431 SPACING (X) = POW (2, e-p)
2435 t = expn - fdigits // e - p.
2436 res = t << fdigits // Form the exponent. Fraction is zero.
2437 if (t < 0) // The result is out of range. Denormalized case.
2442 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2449 real_compnt_info rcs
;
2451 prepare_arg_info (se
, expr
, &rcs
, 0);
2453 masktype
= rcs
.mtype
;
2454 fdigits
= rcs
.fdigits
;
2456 zero
= gfc_build_const (masktype
, integer_zero_node
);
2457 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
2458 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2459 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
2460 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
2461 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2462 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
2463 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2468 /* Generate code for RRSPACING (X) intrinsic function.
2469 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2471 So the result's exponent is p. And if X is normalized, X's fraction part
2472 is the result's fraction. If X is denormalized, to get the X's fraction we
2473 shift X's fraction part to left until the first '1' is removed.
2477 if (expn == 0 && frac == 0)
2481 // edigits is the number of exponent bits. Add the sign bit.
2482 sedigits = edigits + 1;
2484 if (expn == 0) // Denormalized case.
2486 t1 = leadzero (frac);
2487 frac = frac << (t1 + 1); //Remove the first '1'.
2488 frac = frac >> (sedigits); //Form the fraction.
2491 //fdigits is the number of fraction bits. Form the exponent.
2494 res = (t << fdigits) | frac;
2499 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
2502 tree tmp
, t1
, t2
, cond
, cond2
;
2504 tree fdigits
, fraction
;
2505 real_compnt_info rcs
;
2507 prepare_arg_info (se
, expr
, &rcs
, 1);
2508 masktype
= rcs
.mtype
;
2509 fdigits
= rcs
.fdigits
;
2510 fraction
= rcs
.frac
;
2511 one
= gfc_build_const (masktype
, integer_one_node
);
2512 zero
= gfc_build_const (masktype
, integer_zero_node
);
2513 t2
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
);
2515 t1
= call_builtin_clz (masktype
, fraction
);
2516 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
2517 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
2518 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
2519 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
2520 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
2522 tmp
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
);
2523 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
2524 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
2526 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
2527 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
2528 tmp
= build3 (COND_EXPR
, masktype
, cond
,
2529 build_int_cst (masktype
, 0), tmp
);
2531 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
2535 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2538 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
2542 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2543 args
= TREE_VALUE (args
);
2544 args
= gfc_build_addr_expr (NULL
, args
);
2545 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
2546 se
->expr
= gfc_build_function_call (gfor_fndecl_si_kind
, args
);
2549 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2552 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
2554 gfc_actual_arglist
*actual
;
2559 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2561 gfc_init_se (&argse
, se
);
2563 /* Pass a NULL pointer for an absent arg. */
2564 if (actual
->expr
== NULL
)
2565 argse
.expr
= null_pointer_node
;
2567 gfc_conv_expr_reference (&argse
, actual
->expr
);
2569 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2570 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2571 args
= gfc_chainon_list (args
, argse
.expr
);
2573 se
->expr
= gfc_build_function_call (gfor_fndecl_sr_kind
, args
);
2577 /* Generate code for TRIM (A) intrinsic function. */
2580 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
2582 tree gfc_int4_type_node
= gfc_get_int_type (4);
2591 arglist
= NULL_TREE
;
2593 type
= build_pointer_type (gfc_character1_type_node
);
2594 var
= gfc_create_var (type
, "pstr");
2595 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
2596 len
= gfc_create_var (gfc_int4_type_node
, "len");
2598 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
2599 arglist
= gfc_chainon_list (arglist
, gfc_build_addr_expr (NULL
, len
));
2600 arglist
= gfc_chainon_list (arglist
, addr
);
2601 arglist
= chainon (arglist
, tmp
);
2603 tmp
= gfc_build_function_call (gfor_fndecl_string_trim
, arglist
);
2604 gfc_add_expr_to_block (&se
->pre
, tmp
);
2606 /* Free the temporary afterwards, if necessary. */
2607 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
2608 build_int_cst (TREE_TYPE (len
), 0));
2609 arglist
= gfc_chainon_list (NULL_TREE
, var
);
2610 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, arglist
);
2611 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2612 gfc_add_expr_to_block (&se
->post
, tmp
);
2615 se
->string_length
= len
;
2619 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2622 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
2624 tree gfc_int4_type_node
= gfc_get_int_type (4);
2633 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2634 len
= TREE_VALUE (args
);
2635 tmp
= gfc_advance_chain (args
, 2);
2636 ncopies
= TREE_VALUE (tmp
);
2637 len
= fold_build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
);
2638 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
2639 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
2641 arglist
= NULL_TREE
;
2642 arglist
= gfc_chainon_list (arglist
, var
);
2643 arglist
= chainon (arglist
, args
);
2644 tmp
= gfc_build_function_call (gfor_fndecl_string_repeat
, arglist
);
2645 gfc_add_expr_to_block (&se
->pre
, tmp
);
2648 se
->string_length
= len
;
2652 /* Generate code for the IARGC intrinsic. */
2655 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
2661 /* Call the library function. This always returns an INTEGER(4). */
2662 fndecl
= gfor_fndecl_iargc
;
2663 tmp
= gfc_build_function_call (fndecl
, NULL_TREE
);
2665 /* Convert it to the required type. */
2666 type
= gfc_typenode_for_spec (&expr
->ts
);
2667 tmp
= fold_convert (type
, tmp
);
2672 /* Generate code for an intrinsic function. Some map directly to library
2673 calls, others get special handling. In some cases the name of the function
2674 used depends on the type specifiers. */
2677 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
2679 gfc_intrinsic_sym
*isym
;
2683 isym
= expr
->value
.function
.isym
;
2685 name
= &expr
->value
.function
.name
[2];
2689 lib
= gfc_is_intrinsic_libcall (expr
);
2693 se
->ignore_optional
= 1;
2694 gfc_conv_intrinsic_funcall (se
, expr
);
2699 switch (expr
->value
.function
.isym
->generic_id
)
2704 case GFC_ISYM_REPEAT
:
2705 gfc_conv_intrinsic_repeat (se
, expr
);
2709 gfc_conv_intrinsic_trim (se
, expr
);
2712 case GFC_ISYM_SI_KIND
:
2713 gfc_conv_intrinsic_si_kind (se
, expr
);
2716 case GFC_ISYM_SR_KIND
:
2717 gfc_conv_intrinsic_sr_kind (se
, expr
);
2720 case GFC_ISYM_EXPONENT
:
2721 gfc_conv_intrinsic_exponent (se
, expr
);
2724 case GFC_ISYM_SPACING
:
2725 gfc_conv_intrinsic_spacing (se
, expr
);
2728 case GFC_ISYM_RRSPACING
:
2729 gfc_conv_intrinsic_rrspacing (se
, expr
);
2733 gfc_conv_intrinsic_scan (se
, expr
);
2736 case GFC_ISYM_VERIFY
:
2737 gfc_conv_intrinsic_verify (se
, expr
);
2740 case GFC_ISYM_ALLOCATED
:
2741 gfc_conv_allocated (se
, expr
);
2744 case GFC_ISYM_ASSOCIATED
:
2745 gfc_conv_associated(se
, expr
);
2749 gfc_conv_intrinsic_abs (se
, expr
);
2752 case GFC_ISYM_ADJUSTL
:
2753 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
2756 case GFC_ISYM_ADJUSTR
:
2757 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
2760 case GFC_ISYM_AIMAG
:
2761 gfc_conv_intrinsic_imagpart (se
, expr
);
2765 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
2769 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
2772 case GFC_ISYM_ANINT
:
2773 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
2777 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
2780 case GFC_ISYM_BTEST
:
2781 gfc_conv_intrinsic_btest (se
, expr
);
2784 case GFC_ISYM_ACHAR
:
2786 gfc_conv_intrinsic_char (se
, expr
);
2789 case GFC_ISYM_CONVERSION
:
2791 case GFC_ISYM_LOGICAL
:
2793 gfc_conv_intrinsic_conversion (se
, expr
);
2796 /* Integer conversions are handled separately to make sure we get the
2797 correct rounding mode. */
2799 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
2803 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
2806 case GFC_ISYM_CEILING
:
2807 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
2810 case GFC_ISYM_FLOOR
:
2811 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
2815 gfc_conv_intrinsic_mod (se
, expr
, 0);
2818 case GFC_ISYM_MODULO
:
2819 gfc_conv_intrinsic_mod (se
, expr
, 1);
2822 case GFC_ISYM_CMPLX
:
2823 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
2826 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
2827 gfc_conv_intrinsic_iargc (se
, expr
);
2830 case GFC_ISYM_CONJG
:
2831 gfc_conv_intrinsic_conjg (se
, expr
);
2834 case GFC_ISYM_COUNT
:
2835 gfc_conv_intrinsic_count (se
, expr
);
2839 gfc_conv_intrinsic_dim (se
, expr
);
2842 case GFC_ISYM_DPROD
:
2843 gfc_conv_intrinsic_dprod (se
, expr
);
2847 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
2850 case GFC_ISYM_IBCLR
:
2851 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
2854 case GFC_ISYM_IBITS
:
2855 gfc_conv_intrinsic_ibits (se
, expr
);
2858 case GFC_ISYM_IBSET
:
2859 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
2862 case GFC_ISYM_IACHAR
:
2863 case GFC_ISYM_ICHAR
:
2864 /* We assume ASCII character sequence. */
2865 gfc_conv_intrinsic_ichar (se
, expr
);
2868 case GFC_ISYM_IARGC
:
2869 gfc_conv_intrinsic_iargc (se
, expr
);
2873 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
2876 case GFC_ISYM_INDEX
:
2877 gfc_conv_intrinsic_index (se
, expr
);
2881 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
2884 case GFC_ISYM_ISHFT
:
2885 gfc_conv_intrinsic_ishft (se
, expr
);
2888 case GFC_ISYM_ISHFTC
:
2889 gfc_conv_intrinsic_ishftc (se
, expr
);
2892 case GFC_ISYM_LBOUND
:
2893 gfc_conv_intrinsic_bound (se
, expr
, 0);
2897 gfc_conv_intrinsic_len (se
, expr
);
2900 case GFC_ISYM_LEN_TRIM
:
2901 gfc_conv_intrinsic_len_trim (se
, expr
);
2905 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
2909 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
2913 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
2917 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
2921 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
2924 case GFC_ISYM_MAXLOC
:
2925 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
2928 case GFC_ISYM_MAXVAL
:
2929 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
2932 case GFC_ISYM_MERGE
:
2933 gfc_conv_intrinsic_merge (se
, expr
);
2937 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
2940 case GFC_ISYM_MINLOC
:
2941 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
2944 case GFC_ISYM_MINVAL
:
2945 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
2949 gfc_conv_intrinsic_not (se
, expr
);
2952 case GFC_ISYM_PRESENT
:
2953 gfc_conv_intrinsic_present (se
, expr
);
2956 case GFC_ISYM_PRODUCT
:
2957 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
2961 gfc_conv_intrinsic_sign (se
, expr
);
2965 gfc_conv_intrinsic_size (se
, expr
);
2969 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
2972 case GFC_ISYM_TRANSFER
:
2973 gfc_conv_intrinsic_transfer (se
, expr
);
2976 case GFC_ISYM_UBOUND
:
2977 gfc_conv_intrinsic_bound (se
, expr
, 1);
2980 case GFC_ISYM_CHDIR
:
2981 case GFC_ISYM_DOT_PRODUCT
:
2982 case GFC_ISYM_ETIME
:
2984 case GFC_ISYM_FSTAT
:
2985 case GFC_ISYM_GETCWD
:
2986 case GFC_ISYM_GETGID
:
2987 case GFC_ISYM_GETPID
:
2988 case GFC_ISYM_GETUID
:
2989 case GFC_ISYM_HOSTNM
:
2991 case GFC_ISYM_IERRNO
:
2992 case GFC_ISYM_IRAND
:
2994 case GFC_ISYM_MATMUL
:
2996 case GFC_ISYM_RENAME
:
2997 case GFC_ISYM_SECOND
:
2999 case GFC_ISYM_SYMLNK
:
3000 case GFC_ISYM_SYSTEM
:
3002 case GFC_ISYM_TIME8
:
3003 case GFC_ISYM_UMASK
:
3004 case GFC_ISYM_UNLINK
:
3005 gfc_conv_intrinsic_funcall (se
, expr
);
3009 gfc_conv_intrinsic_lib_function (se
, expr
);
3015 /* This generates code to execute before entering the scalarization loop.
3016 Currently does nothing. */
3019 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3021 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3023 case GFC_ISYM_UBOUND
:
3024 case GFC_ISYM_LBOUND
:
3033 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3034 inside the scalarization loop. */
3037 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3041 /* The two argument version returns a scalar. */
3042 if (expr
->value
.function
.actual
->next
->expr
)
3045 newss
= gfc_get_ss ();
3046 newss
->type
= GFC_SS_INTRINSIC
;
3054 /* Walk an intrinsic array libcall. */
3057 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3061 gcc_assert (expr
->rank
> 0);
3063 newss
= gfc_get_ss ();
3064 newss
->type
= GFC_SS_FUNCTION
;
3067 newss
->data
.info
.dimen
= expr
->rank
;
3073 /* Returns nonzero if the specified intrinsic function call maps directly to a
3074 an external library call. Should only be used for functions that return
3078 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3080 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3081 gcc_assert (expr
->rank
> 0);
3083 switch (expr
->value
.function
.isym
->generic_id
)
3087 case GFC_ISYM_COUNT
:
3088 case GFC_ISYM_MATMUL
:
3089 case GFC_ISYM_MAXLOC
:
3090 case GFC_ISYM_MAXVAL
:
3091 case GFC_ISYM_MINLOC
:
3092 case GFC_ISYM_MINVAL
:
3093 case GFC_ISYM_PRODUCT
:
3095 case GFC_ISYM_SHAPE
:
3096 case GFC_ISYM_SPREAD
:
3097 case GFC_ISYM_TRANSPOSE
:
3098 /* Ignore absent optional parameters. */
3101 case GFC_ISYM_RESHAPE
:
3102 case GFC_ISYM_CSHIFT
:
3103 case GFC_ISYM_EOSHIFT
:
3105 case GFC_ISYM_UNPACK
:
3106 /* Pass absent optional parameters. */
3114 /* Walk an intrinsic function. */
3116 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3117 gfc_intrinsic_sym
* isym
)
3121 if (isym
->elemental
)
3122 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_SCALAR
);
3124 if (expr
->rank
== 0)
3127 if (gfc_is_intrinsic_libcall (expr
))
3128 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3130 /* Special cases. */
3131 switch (isym
->generic_id
)
3133 case GFC_ISYM_LBOUND
:
3134 case GFC_ISYM_UBOUND
:
3135 return gfc_walk_intrinsic_bound (ss
, expr
);
3138 /* This probably meant someone forgot to add an intrinsic to the above
3139 list(s) when they implemented it, or something's gone horribly wrong.
3141 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3142 expr
->value
.function
.name
);
3146 #include "gt-fortran-trans-intrinsic.h"