1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
28 #include "coretypes.h"
33 #include "tree-gimple.h"
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 /* This maps fortran intrinsic math functions to external library or GCC
48 typedef struct gfc_intrinsic_map_t
GTY(())
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
52 enum gfc_generic_isym_id id
;
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function code_r4
;
57 enum built_in_function code_r8
;
58 enum built_in_function code_r10
;
59 enum built_in_function code_r16
;
60 enum built_in_function code_c4
;
61 enum built_in_function code_c8
;
62 enum built_in_function code_c10
;
63 enum built_in_function code_c16
;
65 /* True if the naming pattern is to prepend "c" for complex and
66 append "f" for kind=4. False if the naming pattern is to
67 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
70 /* True if a complex version of the function exists. */
71 bool complex_available
;
73 /* True if the function should be marked const. */
76 /* The base library name of this function. */
79 /* Cache decls created for the various operand types. */
91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 defines complex variants of all of the entries in mathbuiltins.def
94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
97 false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
103 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
104 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
107 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
108 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
113 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
114 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
116 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
117 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
119 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
121 /* Functions built into gcc itself. */
122 #include "mathbuiltins.def"
124 /* Functions in libm. */
125 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
126 pattern for other mathbuiltins.def entries. At present we have no
127 optimizations for this in the common sources. */
128 LIBM_FUNCTION (SCALE
, "scalbn", false),
130 /* Functions in libgfortran. */
131 LIBF_FUNCTION (FRACTION
, "fraction", false),
132 LIBF_FUNCTION (NEAREST
, "nearest", false),
133 LIBF_FUNCTION (RRSPACING
, "rrspacing", false),
134 LIBF_FUNCTION (SET_EXPONENT
, "set_exponent", false),
135 LIBF_FUNCTION (SPACING
, "spacing", false),
138 LIBF_FUNCTION (NONE
, NULL
, false)
140 #undef DEFINE_MATH_BUILTIN
141 #undef DEFINE_MATH_BUILTIN_C
145 /* Structure for storing components of a floating number to be used by
146 elemental functions to manipulate reals. */
149 tree arg
; /* Variable tree to view convert to integer. */
150 tree expn
; /* Variable tree to save exponent. */
151 tree frac
; /* Variable tree to save fraction. */
152 tree smask
; /* Constant tree of sign's mask. */
153 tree emask
; /* Constant tree of exponent's mask. */
154 tree fmask
; /* Constant tree of fraction's mask. */
155 tree edigits
; /* Constant tree of the number of exponent bits. */
156 tree fdigits
; /* Constant tree of the number of fraction bits. */
157 tree f1
; /* Constant tree of the f1 defined in the real model. */
158 tree bias
; /* Constant tree of the bias of exponent in the memory. */
159 tree type
; /* Type tree of arg1. */
160 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
164 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
166 /* Evaluate the arguments to an intrinsic function. */
167 /* FIXME: This function and its callers should be rewritten so that it's
168 not necessary to cons up a list to hold the arguments. */
171 gfc_conv_intrinsic_function_args (gfc_se
* se
, gfc_expr
* expr
)
173 gfc_actual_arglist
*actual
;
175 gfc_intrinsic_arg
*formal
;
180 formal
= expr
->value
.function
.isym
->formal
;
182 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
,
183 formal
= formal
? formal
->next
: NULL
)
186 /* Skip omitted optional arguments. */
190 /* Evaluate the parameter. This will substitute scalarized
191 references automatically. */
192 gfc_init_se (&argse
, se
);
194 if (e
->ts
.type
== BT_CHARACTER
)
196 gfc_conv_expr (&argse
, e
);
197 gfc_conv_string_parameter (&argse
);
198 args
= gfc_chainon_list (args
, argse
.string_length
);
201 gfc_conv_expr_val (&argse
, e
);
203 /* If an optional argument is itself an optional dummy argument,
204 check its presence and substitute a null if absent. */
205 if (e
->expr_type
==EXPR_VARIABLE
206 && e
->symtree
->n
.sym
->attr
.optional
209 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
);
211 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
212 gfc_add_block_to_block (&se
->post
, &argse
.post
);
213 args
= gfc_chainon_list (args
, argse
.expr
);
219 /* Conversions between different types are output by the frontend as
220 intrinsic functions. We implement these directly with inline code. */
223 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
228 /* Evaluate the argument. */
229 type
= gfc_typenode_for_spec (&expr
->ts
);
230 gcc_assert (expr
->value
.function
.actual
->expr
);
231 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
232 arg
= TREE_VALUE (arg
);
234 /* Conversion from complex to non-complex involves taking the real
235 component of the value. */
236 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
237 && expr
->ts
.type
!= BT_COMPLEX
)
241 artype
= TREE_TYPE (TREE_TYPE (arg
));
242 arg
= build1 (REALPART_EXPR
, artype
, arg
);
245 se
->expr
= convert (type
, arg
);
248 /* This is needed because the gcc backend only implements
249 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
250 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
251 Similarly for CEILING. */
254 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
261 argtype
= TREE_TYPE (arg
);
262 arg
= gfc_evaluate_now (arg
, pblock
);
264 intval
= convert (type
, arg
);
265 intval
= gfc_evaluate_now (intval
, pblock
);
267 tmp
= convert (argtype
, intval
);
268 cond
= build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
270 tmp
= build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
271 build_int_cst (type
, 1));
272 tmp
= build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
277 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
278 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
281 build_round_expr (stmtblock_t
* pblock
, tree arg
, tree type
)
290 argtype
= TREE_TYPE (arg
);
291 arg
= gfc_evaluate_now (arg
, pblock
);
293 real_from_string (&r
, "0.5");
294 pos
= build_real (argtype
, r
);
296 real_from_string (&r
, "-0.5");
297 neg
= build_real (argtype
, r
);
299 tmp
= gfc_build_const (argtype
, integer_zero_node
);
300 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
302 tmp
= fold_build3 (COND_EXPR
, argtype
, cond
, pos
, neg
);
303 tmp
= fold_build2 (PLUS_EXPR
, argtype
, arg
, tmp
);
304 return fold_build1 (FIX_TRUNC_EXPR
, type
, tmp
);
308 /* Convert a real to an integer using a specific rounding mode.
309 Ideally we would just build the corresponding GENERIC node,
310 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
313 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
314 enum rounding_mode op
)
319 return build_fixbound_expr (pblock
, arg
, type
, 0);
323 return build_fixbound_expr (pblock
, arg
, type
, 1);
327 return build_round_expr (pblock
, arg
, type
);
330 gcc_assert (op
== RND_TRUNC
);
331 return build1 (FIX_TRUNC_EXPR
, type
, arg
);
336 /* Round a real value using the specified rounding mode.
337 We use a temporary integer of that same kind size as the result.
338 Values larger than those that can be represented by this kind are
339 unchanged, as they will not be accurate enough to represent the
341 huge = HUGE (KIND (a))
342 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
346 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
357 kind
= expr
->ts
.kind
;
360 /* We have builtin functions for some cases. */
403 /* Evaluate the argument. */
404 gcc_assert (expr
->value
.function
.actual
->expr
);
405 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
407 /* Use a builtin function if one exists. */
408 if (n
!= END_BUILTINS
)
410 tmp
= built_in_decls
[n
];
411 se
->expr
= build_function_call_expr (tmp
, arg
);
415 /* This code is probably redundant, but we'll keep it lying around just
417 type
= gfc_typenode_for_spec (&expr
->ts
);
418 arg
= TREE_VALUE (arg
);
419 arg
= gfc_evaluate_now (arg
, &se
->pre
);
421 /* Test if the value is too large to handle sensibly. */
422 gfc_set_model_kind (kind
);
424 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
425 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
426 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
427 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
429 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
430 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
431 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
432 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
433 itype
= gfc_get_int_type (kind
);
435 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
436 tmp
= convert (type
, tmp
);
437 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
442 /* Convert to an integer using the specified rounding mode. */
445 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
450 /* Evaluate the argument. */
451 type
= gfc_typenode_for_spec (&expr
->ts
);
452 gcc_assert (expr
->value
.function
.actual
->expr
);
453 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
454 arg
= TREE_VALUE (arg
);
456 if (TREE_CODE (TREE_TYPE (arg
)) == INTEGER_TYPE
)
458 /* Conversion to a different integer kind. */
459 se
->expr
= convert (type
, arg
);
463 /* Conversion from complex to non-complex involves taking the real
464 component of the value. */
465 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
466 && expr
->ts
.type
!= BT_COMPLEX
)
470 artype
= TREE_TYPE (TREE_TYPE (arg
));
471 arg
= build1 (REALPART_EXPR
, artype
, arg
);
474 se
->expr
= build_fix_expr (&se
->pre
, arg
, type
, op
);
479 /* Get the imaginary component of a value. */
482 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
486 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
487 arg
= TREE_VALUE (arg
);
488 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
492 /* Get the complex conjugate of a value. */
495 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
499 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
500 arg
= TREE_VALUE (arg
);
501 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
505 /* Initialize function decls for library functions. The external functions
506 are created as required. Builtin functions are added here. */
509 gfc_build_intrinsic_lib_fndecls (void)
511 gfc_intrinsic_map_t
*m
;
513 /* Add GCC builtin functions. */
514 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
516 if (m
->code_r4
!= END_BUILTINS
)
517 m
->real4_decl
= built_in_decls
[m
->code_r4
];
518 if (m
->code_r8
!= END_BUILTINS
)
519 m
->real8_decl
= built_in_decls
[m
->code_r8
];
520 if (m
->code_r10
!= END_BUILTINS
)
521 m
->real10_decl
= built_in_decls
[m
->code_r10
];
522 if (m
->code_r16
!= END_BUILTINS
)
523 m
->real16_decl
= built_in_decls
[m
->code_r16
];
524 if (m
->code_c4
!= END_BUILTINS
)
525 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
526 if (m
->code_c8
!= END_BUILTINS
)
527 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
528 if (m
->code_c10
!= END_BUILTINS
)
529 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
530 if (m
->code_c16
!= END_BUILTINS
)
531 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
536 /* Create a fndecl for a simple intrinsic library function. */
539 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
544 gfc_actual_arglist
*actual
;
547 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
550 if (ts
->type
== BT_REAL
)
555 pdecl
= &m
->real4_decl
;
558 pdecl
= &m
->real8_decl
;
561 pdecl
= &m
->real10_decl
;
564 pdecl
= &m
->real16_decl
;
570 else if (ts
->type
== BT_COMPLEX
)
572 gcc_assert (m
->complex_available
);
577 pdecl
= &m
->complex4_decl
;
580 pdecl
= &m
->complex8_decl
;
583 pdecl
= &m
->complex10_decl
;
586 pdecl
= &m
->complex16_decl
;
601 snprintf (name
, sizeof (name
), "%s%s%s",
602 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
603 else if (ts
->kind
== 8)
604 snprintf (name
, sizeof (name
), "%s%s",
605 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
608 gcc_assert (ts
->kind
== 10 || ts
->kind
== 16);
609 snprintf (name
, sizeof (name
), "%s%s%s",
610 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
615 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
616 ts
->type
== BT_COMPLEX
? 'c' : 'r',
620 argtypes
= NULL_TREE
;
621 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
623 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
624 argtypes
= gfc_chainon_list (argtypes
, type
);
626 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
627 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
628 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
630 /* Mark the decl as external. */
631 DECL_EXTERNAL (fndecl
) = 1;
632 TREE_PUBLIC (fndecl
) = 1;
634 /* Mark it __attribute__((const)), if possible. */
635 TREE_READONLY (fndecl
) = m
->is_constant
;
637 rest_of_decl_compilation (fndecl
, 1, 0);
644 /* Convert an intrinsic function into an external or builtin call. */
647 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
649 gfc_intrinsic_map_t
*m
;
652 gfc_generic_isym_id id
;
654 id
= expr
->value
.function
.isym
->generic_id
;
655 /* Find the entry for this function. */
656 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
662 if (m
->id
== GFC_ISYM_NONE
)
664 internal_error ("Intrinsic function %s(%d) not recognized",
665 expr
->value
.function
.name
, id
);
668 /* Get the decl and generate the call. */
669 args
= gfc_conv_intrinsic_function_args (se
, expr
);
670 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
671 se
->expr
= build_function_call_expr (fndecl
, args
);
674 /* Generate code for EXPONENT(X) intrinsic function. */
677 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
682 args
= gfc_conv_intrinsic_function_args (se
, expr
);
684 a1
= expr
->value
.function
.actual
->expr
;
688 fndecl
= gfor_fndecl_math_exponent4
;
691 fndecl
= gfor_fndecl_math_exponent8
;
694 fndecl
= gfor_fndecl_math_exponent10
;
697 fndecl
= gfor_fndecl_math_exponent16
;
703 se
->expr
= build_function_call_expr (fndecl
, args
);
706 /* Evaluate a single upper or lower bound. */
707 /* TODO: bound intrinsic generates way too much unnecessary code. */
710 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
712 gfc_actual_arglist
*arg
;
713 gfc_actual_arglist
*arg2
;
718 tree cond
, cond1
, cond2
, cond3
, cond4
, size
;
726 arg
= expr
->value
.function
.actual
;
731 /* Create an implicit second parameter from the loop variable. */
732 gcc_assert (!arg2
->expr
);
733 gcc_assert (se
->loop
->dimen
== 1);
734 gcc_assert (se
->ss
->expr
== expr
);
735 gfc_advance_se_ss_chain (se
);
736 bound
= se
->loop
->loopvar
[0];
737 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
742 /* use the passed argument. */
743 gcc_assert (arg
->next
->expr
);
744 gfc_init_se (&argse
, NULL
);
745 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
746 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
748 /* Convert from one based to zero based. */
749 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
753 /* TODO: don't re-evaluate the descriptor on each iteration. */
754 /* Get a descriptor for the first parameter. */
755 ss
= gfc_walk_expr (arg
->expr
);
756 gcc_assert (ss
!= gfc_ss_terminator
);
757 gfc_init_se (&argse
, NULL
);
758 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
759 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
760 gfc_add_block_to_block (&se
->post
, &argse
.post
);
764 if (INTEGER_CST_P (bound
))
768 hi
= TREE_INT_CST_HIGH (bound
);
769 low
= TREE_INT_CST_LOW (bound
);
770 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
771 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
772 "dimension index", upper
? "UBOUND" : "LBOUND",
777 if (flag_bounds_check
)
779 bound
= gfc_evaluate_now (bound
, &se
->pre
);
780 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
781 bound
, build_int_cst (TREE_TYPE (bound
), 0));
782 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
783 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
784 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
785 gfc_trans_runtime_check (cond
, gfc_msg_fault
, &se
->pre
, &expr
->where
);
789 ubound
= gfc_conv_descriptor_ubound (desc
, bound
);
790 lbound
= gfc_conv_descriptor_lbound (desc
, bound
);
792 /* Follow any component references. */
793 if (arg
->expr
->expr_type
== EXPR_VARIABLE
794 || arg
->expr
->expr_type
== EXPR_CONSTANT
)
796 as
= arg
->expr
->symtree
->n
.sym
->as
;
797 for (ref
= arg
->expr
->ref
; ref
; ref
= ref
->next
)
802 as
= ref
->u
.c
.component
->as
;
810 switch (ref
->u
.ar
.type
)
828 /* 13.14.53: Result value for LBOUND
830 Case (i): For an array section or for an array expression other than a
831 whole array or array structure component, LBOUND(ARRAY, DIM)
832 has the value 1. For a whole array or array structure
833 component, LBOUND(ARRAY, DIM) has the value:
834 (a) equal to the lower bound for subscript DIM of ARRAY if
835 dimension DIM of ARRAY does not have extent zero
836 or if ARRAY is an assumed-size array of rank DIM,
839 13.14.113: Result value for UBOUND
841 Case (i): For an array section or for an array expression other than a
842 whole array or array structure component, UBOUND(ARRAY, DIM)
843 has the value equal to the number of elements in the given
844 dimension; otherwise, it has a value equal to the upper bound
845 for subscript DIM of ARRAY if dimension DIM of ARRAY does
846 not have size zero and has value zero if dimension DIM has
851 tree stride
= gfc_conv_descriptor_stride (desc
, bound
);
853 cond1
= fold_build2 (GE_EXPR
, boolean_type_node
, ubound
, lbound
);
854 cond2
= fold_build2 (LE_EXPR
, boolean_type_node
, ubound
, lbound
);
856 cond3
= fold_build2 (GE_EXPR
, boolean_type_node
, stride
,
857 gfc_index_zero_node
);
858 cond3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond3
, cond1
);
860 cond4
= fold_build2 (LT_EXPR
, boolean_type_node
, stride
,
861 gfc_index_zero_node
);
862 cond4
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond4
, cond2
);
866 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
868 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
869 ubound
, gfc_index_zero_node
);
873 if (as
->type
== AS_ASSUMED_SIZE
)
874 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, bound
,
875 build_int_cst (TREE_TYPE (bound
),
876 arg
->expr
->rank
- 1));
878 cond
= boolean_false_node
;
880 cond1
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
881 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond1
);
883 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
884 lbound
, gfc_index_one_node
);
891 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
892 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
896 se
->expr
= gfc_index_one_node
;
899 type
= gfc_typenode_for_spec (&expr
->ts
);
900 se
->expr
= convert (type
, se
->expr
);
905 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
911 args
= gfc_conv_intrinsic_function_args (se
, expr
);
912 gcc_assert (args
&& TREE_CHAIN (args
) == NULL_TREE
);
913 val
= TREE_VALUE (args
);
915 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
919 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (val
), val
);
923 switch (expr
->ts
.kind
)
938 se
->expr
= build_function_call_expr (built_in_decls
[n
], args
);
947 /* Create a complex value from one or two real components. */
950 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
957 type
= gfc_typenode_for_spec (&expr
->ts
);
958 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
959 real
= convert (TREE_TYPE (type
), TREE_VALUE (arg
));
961 imag
= convert (TREE_TYPE (type
), TREE_VALUE (TREE_CHAIN (arg
)));
962 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg
))) == COMPLEX_TYPE
)
964 arg
= TREE_VALUE (arg
);
965 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
966 imag
= convert (TREE_TYPE (type
), imag
);
969 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
971 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
974 /* Remainder function MOD(A, P) = A - INT(A / P) * P
975 MODULO(A, P) = A - FLOOR (A / P) * P */
976 /* TODO: MOD(x, 0) */
979 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
991 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
993 switch (expr
->ts
.type
)
996 /* Integer case is easy, we've got a builtin op. */
997 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
998 arg
= TREE_VALUE (arg
);
999 type
= TREE_TYPE (arg
);
1002 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, arg
, arg2
);
1004 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, arg
, arg2
);
1009 /* Check if we have a builtin fmod. */
1010 switch (expr
->ts
.kind
)
1029 /* Use it if it exists. */
1030 if (n
!= END_BUILTINS
)
1032 tmp
= built_in_decls
[n
];
1033 se
->expr
= build_function_call_expr (tmp
, arg
);
1038 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1039 arg
= TREE_VALUE (arg
);
1040 type
= TREE_TYPE (arg
);
1042 arg
= gfc_evaluate_now (arg
, &se
->pre
);
1043 arg2
= gfc_evaluate_now (arg2
, &se
->pre
);
1046 modulo = arg - floor (arg/arg2) * arg2, so
1047 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1049 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1050 thereby avoiding another division and retaining the accuracy
1051 of the builtin function. */
1052 if (n
!= END_BUILTINS
&& modulo
)
1054 tree zero
= gfc_build_const (type
, integer_zero_node
);
1055 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1056 test
= build2 (LT_EXPR
, boolean_type_node
, arg
, zero
);
1057 test2
= build2 (LT_EXPR
, boolean_type_node
, arg2
, zero
);
1058 test2
= build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
1059 test
= build2 (NE_EXPR
, boolean_type_node
, tmp
, zero
);
1060 test
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1061 test
= gfc_evaluate_now (test
, &se
->pre
);
1062 se
->expr
= build3 (COND_EXPR
, type
, test
,
1063 build2 (PLUS_EXPR
, type
, tmp
, arg2
), tmp
);
1067 /* If we do not have a built_in fmod, the calculation is going to
1068 have to be done longhand. */
1069 tmp
= build2 (RDIV_EXPR
, type
, arg
, arg2
);
1071 /* Test if the value is too large to handle sensibly. */
1072 gfc_set_model_kind (expr
->ts
.kind
);
1074 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1075 ikind
= expr
->ts
.kind
;
1078 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1079 ikind
= gfc_max_integer_kind
;
1081 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1082 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1083 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
1085 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1086 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1087 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
1088 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1090 itype
= gfc_get_int_type (ikind
);
1092 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1094 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1095 tmp
= convert (type
, tmp
);
1096 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, arg
);
1097 tmp
= build2 (MULT_EXPR
, type
, tmp
, arg2
);
1098 se
->expr
= build2 (MINUS_EXPR
, type
, arg
, tmp
);
1107 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1110 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1119 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1120 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1121 arg
= TREE_VALUE (arg
);
1122 type
= TREE_TYPE (arg
);
1124 val
= build2 (MINUS_EXPR
, type
, arg
, arg2
);
1125 val
= gfc_evaluate_now (val
, &se
->pre
);
1127 zero
= gfc_build_const (type
, integer_zero_node
);
1128 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
1129 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
1133 /* SIGN(A, B) is absolute value of A times sign of B.
1134 The real value versions use library functions to ensure the correct
1135 handling of negative zero. Integer case implemented as:
1136 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1140 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1147 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1148 if (expr
->ts
.type
== BT_REAL
)
1150 switch (expr
->ts
.kind
)
1153 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
1156 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
1160 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
1165 se
->expr
= build_function_call_expr (tmp
, arg
);
1169 /* Having excluded floating point types, we know we are now dealing
1170 with signed integer types. */
1171 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1172 arg
= TREE_VALUE (arg
);
1173 type
= TREE_TYPE (arg
);
1175 /* Arg is used multiple times below. */
1176 arg
= gfc_evaluate_now (arg
, &se
->pre
);
1178 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1179 the signs of A and B are the same, and of all ones if they differ. */
1180 tmp
= fold_build2 (BIT_XOR_EXPR
, type
, arg
, arg2
);
1181 tmp
= fold_build2 (RSHIFT_EXPR
, type
, tmp
,
1182 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1183 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1185 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1186 is all ones (i.e. -1). */
1187 se
->expr
= fold_build2 (BIT_XOR_EXPR
, type
,
1188 fold_build2 (PLUS_EXPR
, type
, arg
, tmp
),
1193 /* Test for the presence of an optional argument. */
1196 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1200 arg
= expr
->value
.function
.actual
->expr
;
1201 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1202 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1203 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1207 /* Calculate the double precision product of two single precision values. */
1210 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1216 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1217 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1218 arg
= TREE_VALUE (arg
);
1220 /* Convert the args to double precision before multiplying. */
1221 type
= gfc_typenode_for_spec (&expr
->ts
);
1222 arg
= convert (type
, arg
);
1223 arg2
= convert (type
, arg2
);
1224 se
->expr
= build2 (MULT_EXPR
, type
, arg
, arg2
);
1228 /* Return a length one character string containing an ascii character. */
1231 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1237 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1238 arg
= TREE_VALUE (arg
);
1240 /* We currently don't support character types != 1. */
1241 gcc_assert (expr
->ts
.kind
== 1);
1242 type
= gfc_character1_type_node
;
1243 var
= gfc_create_var (type
, "char");
1245 arg
= convert (type
, arg
);
1246 gfc_add_modify_expr (&se
->pre
, var
, arg
);
1247 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1248 se
->string_length
= integer_one_node
;
1253 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1261 tree gfc_int8_type_node
= gfc_get_int_type (8);
1263 type
= build_pointer_type (gfc_character1_type_node
);
1264 var
= gfc_create_var (type
, "pstr");
1265 len
= gfc_create_var (gfc_int8_type_node
, "len");
1267 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1268 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1269 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1270 arglist
= chainon (arglist
, tmp
);
1272 tmp
= build_function_call_expr (gfor_fndecl_ctime
, arglist
);
1273 gfc_add_expr_to_block (&se
->pre
, tmp
);
1275 /* Free the temporary afterwards, if necessary. */
1276 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1277 build_int_cst (TREE_TYPE (len
), 0));
1278 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, var
);
1279 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1280 gfc_add_expr_to_block (&se
->post
, tmp
);
1283 se
->string_length
= len
;
1288 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1296 tree gfc_int4_type_node
= gfc_get_int_type (4);
1298 type
= build_pointer_type (gfc_character1_type_node
);
1299 var
= gfc_create_var (type
, "pstr");
1300 len
= gfc_create_var (gfc_int4_type_node
, "len");
1302 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1303 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1304 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1305 arglist
= chainon (arglist
, tmp
);
1307 tmp
= build_function_call_expr (gfor_fndecl_fdate
, arglist
);
1308 gfc_add_expr_to_block (&se
->pre
, tmp
);
1310 /* Free the temporary afterwards, if necessary. */
1311 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1312 build_int_cst (TREE_TYPE (len
), 0));
1313 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, var
);
1314 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1315 gfc_add_expr_to_block (&se
->post
, tmp
);
1318 se
->string_length
= len
;
1322 /* Return a character string containing the tty name. */
1325 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1333 tree gfc_int4_type_node
= gfc_get_int_type (4);
1335 type
= build_pointer_type (gfc_character1_type_node
);
1336 var
= gfc_create_var (type
, "pstr");
1337 len
= gfc_create_var (gfc_int4_type_node
, "len");
1339 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1340 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1341 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1342 arglist
= chainon (arglist
, tmp
);
1344 tmp
= build_function_call_expr (gfor_fndecl_ttynam
, arglist
);
1345 gfc_add_expr_to_block (&se
->pre
, tmp
);
1347 /* Free the temporary afterwards, if necessary. */
1348 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1349 build_int_cst (TREE_TYPE (len
), 0));
1350 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, var
);
1351 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1352 gfc_add_expr_to_block (&se
->post
, tmp
);
1355 se
->string_length
= len
;
1359 /* Get the minimum/maximum value of all the parameters.
1360 minmax (a1, a2, a3, ...)
1373 /* TODO: Mismatching types can occur when specific names are used.
1374 These should be handled during resolution. */
1376 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1387 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1388 type
= gfc_typenode_for_spec (&expr
->ts
);
1390 limit
= TREE_VALUE (arg
);
1391 if (TREE_TYPE (limit
) != type
)
1392 limit
= convert (type
, limit
);
1393 /* Only evaluate the argument once. */
1394 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1395 limit
= gfc_evaluate_now (limit
, &se
->pre
);
1397 mvar
= gfc_create_var (type
, "M");
1398 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1399 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1401 val
= TREE_VALUE (arg
);
1402 if (TREE_TYPE (val
) != type
)
1403 val
= convert (type
, val
);
1405 /* Only evaluate the argument once. */
1406 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1407 val
= gfc_evaluate_now (val
, &se
->pre
);
1409 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1411 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1412 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1413 gfc_add_expr_to_block (&se
->pre
, tmp
);
1414 elsecase
= build_empty_stmt ();
1421 /* Create a symbol node for this intrinsic. The symbol from the frontend
1422 has the generic name. */
1425 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1429 /* TODO: Add symbols for intrinsic function to the global namespace. */
1430 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1431 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1434 sym
->attr
.external
= 1;
1435 sym
->attr
.function
= 1;
1436 sym
->attr
.always_explicit
= 1;
1437 sym
->attr
.proc
= PROC_INTRINSIC
;
1438 sym
->attr
.flavor
= FL_PROCEDURE
;
1442 sym
->attr
.dimension
= 1;
1443 sym
->as
= gfc_get_array_spec ();
1444 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1445 sym
->as
->rank
= expr
->rank
;
1448 /* TODO: proper argument lists for external intrinsics. */
1452 /* Generate a call to an external intrinsic function. */
1454 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1459 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1462 gcc_assert (expr
->rank
> 0);
1464 gcc_assert (expr
->rank
== 0);
1466 sym
= gfc_get_symbol_for_expr (expr
);
1468 /* Calls to libgfortran_matmul need to be appended special arguments,
1469 to be able to call the BLAS ?gemm functions if required and possible. */
1470 append_args
= NULL_TREE
;
1471 if (expr
->value
.function
.isym
->generic_id
== GFC_ISYM_MATMUL
1472 && sym
->ts
.type
!= BT_LOGICAL
)
1474 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1476 if (gfc_option
.flag_external_blas
1477 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1478 && (sym
->ts
.kind
== gfc_default_real_kind
1479 || sym
->ts
.kind
== gfc_default_double_kind
))
1483 if (sym
->ts
.type
== BT_REAL
)
1485 if (sym
->ts
.kind
== gfc_default_real_kind
)
1486 gemm_fndecl
= gfor_fndecl_sgemm
;
1488 gemm_fndecl
= gfor_fndecl_dgemm
;
1492 if (sym
->ts
.kind
== gfc_default_real_kind
)
1493 gemm_fndecl
= gfor_fndecl_cgemm
;
1495 gemm_fndecl
= gfor_fndecl_zgemm
;
1498 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 1));
1499 append_args
= gfc_chainon_list
1500 (append_args
, build_int_cst
1501 (cint
, gfc_option
.blas_matmul_limit
));
1502 append_args
= gfc_chainon_list (append_args
,
1503 gfc_build_addr_expr (NULL_TREE
,
1508 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 0));
1509 append_args
= gfc_chainon_list (append_args
, build_int_cst (cint
, 0));
1510 append_args
= gfc_chainon_list (append_args
, null_pointer_node
);
1514 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
1518 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1538 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1547 gfc_actual_arglist
*actual
;
1554 gfc_conv_intrinsic_funcall (se
, expr
);
1558 actual
= expr
->value
.function
.actual
;
1559 type
= gfc_typenode_for_spec (&expr
->ts
);
1560 /* Initialize the result. */
1561 resvar
= gfc_create_var (type
, "test");
1563 tmp
= convert (type
, boolean_true_node
);
1565 tmp
= convert (type
, boolean_false_node
);
1566 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1568 /* Walk the arguments. */
1569 arrayss
= gfc_walk_expr (actual
->expr
);
1570 gcc_assert (arrayss
!= gfc_ss_terminator
);
1572 /* Initialize the scalarizer. */
1573 gfc_init_loopinfo (&loop
);
1574 exit_label
= gfc_build_label_decl (NULL_TREE
);
1575 TREE_USED (exit_label
) = 1;
1576 gfc_add_ss_to_loop (&loop
, arrayss
);
1578 /* Initialize the loop. */
1579 gfc_conv_ss_startstride (&loop
);
1580 gfc_conv_loop_setup (&loop
);
1582 gfc_mark_ss_chain_used (arrayss
, 1);
1583 /* Generate the loop body. */
1584 gfc_start_scalarized_body (&loop
, &body
);
1586 /* If the condition matches then set the return value. */
1587 gfc_start_block (&block
);
1589 tmp
= convert (type
, boolean_false_node
);
1591 tmp
= convert (type
, boolean_true_node
);
1592 gfc_add_modify_expr (&block
, resvar
, tmp
);
1594 /* And break out of the loop. */
1595 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1596 gfc_add_expr_to_block (&block
, tmp
);
1598 found
= gfc_finish_block (&block
);
1600 /* Check this element. */
1601 gfc_init_se (&arrayse
, NULL
);
1602 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1603 arrayse
.ss
= arrayss
;
1604 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1606 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1607 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1608 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1609 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1610 gfc_add_expr_to_block (&body
, tmp
);
1611 gfc_add_block_to_block (&body
, &arrayse
.post
);
1613 gfc_trans_scalarizing_loops (&loop
, &body
);
1615 /* Add the exit label. */
1616 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1617 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1619 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1620 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1621 gfc_cleanup_loop (&loop
);
1626 /* COUNT(A) = Number of true elements in A. */
1628 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1635 gfc_actual_arglist
*actual
;
1641 gfc_conv_intrinsic_funcall (se
, expr
);
1645 actual
= expr
->value
.function
.actual
;
1647 type
= gfc_typenode_for_spec (&expr
->ts
);
1648 /* Initialize the result. */
1649 resvar
= gfc_create_var (type
, "count");
1650 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1652 /* Walk the arguments. */
1653 arrayss
= gfc_walk_expr (actual
->expr
);
1654 gcc_assert (arrayss
!= gfc_ss_terminator
);
1656 /* Initialize the scalarizer. */
1657 gfc_init_loopinfo (&loop
);
1658 gfc_add_ss_to_loop (&loop
, arrayss
);
1660 /* Initialize the loop. */
1661 gfc_conv_ss_startstride (&loop
);
1662 gfc_conv_loop_setup (&loop
);
1664 gfc_mark_ss_chain_used (arrayss
, 1);
1665 /* Generate the loop body. */
1666 gfc_start_scalarized_body (&loop
, &body
);
1668 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1669 build_int_cst (TREE_TYPE (resvar
), 1));
1670 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1672 gfc_init_se (&arrayse
, NULL
);
1673 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1674 arrayse
.ss
= arrayss
;
1675 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1676 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1678 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1679 gfc_add_expr_to_block (&body
, tmp
);
1680 gfc_add_block_to_block (&body
, &arrayse
.post
);
1682 gfc_trans_scalarizing_loops (&loop
, &body
);
1684 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1685 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1686 gfc_cleanup_loop (&loop
);
1691 /* Inline implementation of the sum and product intrinsics. */
1693 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1701 gfc_actual_arglist
*actual
;
1706 gfc_expr
*arrayexpr
;
1711 gfc_conv_intrinsic_funcall (se
, expr
);
1715 type
= gfc_typenode_for_spec (&expr
->ts
);
1716 /* Initialize the result. */
1717 resvar
= gfc_create_var (type
, "val");
1718 if (op
== PLUS_EXPR
)
1719 tmp
= gfc_build_const (type
, integer_zero_node
);
1721 tmp
= gfc_build_const (type
, integer_one_node
);
1723 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1725 /* Walk the arguments. */
1726 actual
= expr
->value
.function
.actual
;
1727 arrayexpr
= actual
->expr
;
1728 arrayss
= gfc_walk_expr (arrayexpr
);
1729 gcc_assert (arrayss
!= gfc_ss_terminator
);
1731 actual
= actual
->next
->next
;
1732 gcc_assert (actual
);
1733 maskexpr
= actual
->expr
;
1734 if (maskexpr
&& maskexpr
->rank
!= 0)
1736 maskss
= gfc_walk_expr (maskexpr
);
1737 gcc_assert (maskss
!= gfc_ss_terminator
);
1742 /* Initialize the scalarizer. */
1743 gfc_init_loopinfo (&loop
);
1744 gfc_add_ss_to_loop (&loop
, arrayss
);
1746 gfc_add_ss_to_loop (&loop
, maskss
);
1748 /* Initialize the loop. */
1749 gfc_conv_ss_startstride (&loop
);
1750 gfc_conv_loop_setup (&loop
);
1752 gfc_mark_ss_chain_used (arrayss
, 1);
1754 gfc_mark_ss_chain_used (maskss
, 1);
1755 /* Generate the loop body. */
1756 gfc_start_scalarized_body (&loop
, &body
);
1758 /* If we have a mask, only add this element if the mask is set. */
1761 gfc_init_se (&maskse
, NULL
);
1762 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1764 gfc_conv_expr_val (&maskse
, maskexpr
);
1765 gfc_add_block_to_block (&body
, &maskse
.pre
);
1767 gfc_start_block (&block
);
1770 gfc_init_block (&block
);
1772 /* Do the actual summation/product. */
1773 gfc_init_se (&arrayse
, NULL
);
1774 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1775 arrayse
.ss
= arrayss
;
1776 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1777 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1779 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1780 gfc_add_modify_expr (&block
, resvar
, tmp
);
1781 gfc_add_block_to_block (&block
, &arrayse
.post
);
1785 /* We enclose the above in if (mask) {...} . */
1786 tmp
= gfc_finish_block (&block
);
1788 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1791 tmp
= gfc_finish_block (&block
);
1792 gfc_add_expr_to_block (&body
, tmp
);
1794 gfc_trans_scalarizing_loops (&loop
, &body
);
1796 /* For a scalar mask, enclose the loop in an if statement. */
1797 if (maskexpr
&& maskss
== NULL
)
1799 gfc_init_se (&maskse
, NULL
);
1800 gfc_conv_expr_val (&maskse
, maskexpr
);
1801 gfc_init_block (&block
);
1802 gfc_add_block_to_block (&block
, &loop
.pre
);
1803 gfc_add_block_to_block (&block
, &loop
.post
);
1804 tmp
= gfc_finish_block (&block
);
1806 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1807 gfc_add_expr_to_block (&block
, tmp
);
1808 gfc_add_block_to_block (&se
->pre
, &block
);
1812 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1813 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1816 gfc_cleanup_loop (&loop
);
1822 /* Inline implementation of the dot_product intrinsic. This function
1823 is based on gfc_conv_intrinsic_arith (the previous function). */
1825 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1833 gfc_actual_arglist
*actual
;
1834 gfc_ss
*arrayss1
, *arrayss2
;
1835 gfc_se arrayse1
, arrayse2
;
1836 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1838 type
= gfc_typenode_for_spec (&expr
->ts
);
1840 /* Initialize the result. */
1841 resvar
= gfc_create_var (type
, "val");
1842 if (expr
->ts
.type
== BT_LOGICAL
)
1843 tmp
= convert (type
, integer_zero_node
);
1845 tmp
= gfc_build_const (type
, integer_zero_node
);
1847 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1849 /* Walk argument #1. */
1850 actual
= expr
->value
.function
.actual
;
1851 arrayexpr1
= actual
->expr
;
1852 arrayss1
= gfc_walk_expr (arrayexpr1
);
1853 gcc_assert (arrayss1
!= gfc_ss_terminator
);
1855 /* Walk argument #2. */
1856 actual
= actual
->next
;
1857 arrayexpr2
= actual
->expr
;
1858 arrayss2
= gfc_walk_expr (arrayexpr2
);
1859 gcc_assert (arrayss2
!= gfc_ss_terminator
);
1861 /* Initialize the scalarizer. */
1862 gfc_init_loopinfo (&loop
);
1863 gfc_add_ss_to_loop (&loop
, arrayss1
);
1864 gfc_add_ss_to_loop (&loop
, arrayss2
);
1866 /* Initialize the loop. */
1867 gfc_conv_ss_startstride (&loop
);
1868 gfc_conv_loop_setup (&loop
);
1870 gfc_mark_ss_chain_used (arrayss1
, 1);
1871 gfc_mark_ss_chain_used (arrayss2
, 1);
1873 /* Generate the loop body. */
1874 gfc_start_scalarized_body (&loop
, &body
);
1875 gfc_init_block (&block
);
1877 /* Make the tree expression for [conjg(]array1[)]. */
1878 gfc_init_se (&arrayse1
, NULL
);
1879 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
1880 arrayse1
.ss
= arrayss1
;
1881 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
1882 if (expr
->ts
.type
== BT_COMPLEX
)
1883 arrayse1
.expr
= build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
1884 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
1886 /* Make the tree expression for array2. */
1887 gfc_init_se (&arrayse2
, NULL
);
1888 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
1889 arrayse2
.ss
= arrayss2
;
1890 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
1891 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
1893 /* Do the actual product and sum. */
1894 if (expr
->ts
.type
== BT_LOGICAL
)
1896 tmp
= build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
1897 tmp
= build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
1901 tmp
= build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
1902 tmp
= build2 (PLUS_EXPR
, type
, resvar
, tmp
);
1904 gfc_add_modify_expr (&block
, resvar
, tmp
);
1906 /* Finish up the loop block and the loop. */
1907 tmp
= gfc_finish_block (&block
);
1908 gfc_add_expr_to_block (&body
, tmp
);
1910 gfc_trans_scalarizing_loops (&loop
, &body
);
1911 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1912 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1913 gfc_cleanup_loop (&loop
);
1920 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1924 stmtblock_t ifblock
;
1925 stmtblock_t elseblock
;
1932 gfc_actual_arglist
*actual
;
1937 gfc_expr
*arrayexpr
;
1944 gfc_conv_intrinsic_funcall (se
, expr
);
1948 /* Initialize the result. */
1949 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1950 type
= gfc_typenode_for_spec (&expr
->ts
);
1952 /* Walk the arguments. */
1953 actual
= expr
->value
.function
.actual
;
1954 arrayexpr
= actual
->expr
;
1955 arrayss
= gfc_walk_expr (arrayexpr
);
1956 gcc_assert (arrayss
!= gfc_ss_terminator
);
1958 actual
= actual
->next
->next
;
1959 gcc_assert (actual
);
1960 maskexpr
= actual
->expr
;
1961 if (maskexpr
&& maskexpr
->rank
!= 0)
1963 maskss
= gfc_walk_expr (maskexpr
);
1964 gcc_assert (maskss
!= gfc_ss_terminator
);
1969 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1970 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1971 switch (arrayexpr
->ts
.type
)
1974 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1978 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1979 arrayexpr
->ts
.kind
);
1986 /* We start with the most negative possible value for MAXLOC, and the most
1987 positive possible value for MINLOC. The most negative possible value is
1988 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
1989 possible value is HUGE in both cases. */
1991 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1992 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1994 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
1995 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
1996 build_int_cst (type
, 1));
1998 /* Initialize the scalarizer. */
1999 gfc_init_loopinfo (&loop
);
2000 gfc_add_ss_to_loop (&loop
, arrayss
);
2002 gfc_add_ss_to_loop (&loop
, maskss
);
2004 /* Initialize the loop. */
2005 gfc_conv_ss_startstride (&loop
);
2006 gfc_conv_loop_setup (&loop
);
2008 gcc_assert (loop
.dimen
== 1);
2010 /* Initialize the position to zero, following Fortran 2003. We are free
2011 to do this because Fortran 95 allows the result of an entirely false
2012 mask to be processor dependent. */
2013 gfc_add_modify_expr (&loop
.pre
, pos
, gfc_index_zero_node
);
2015 gfc_mark_ss_chain_used (arrayss
, 1);
2017 gfc_mark_ss_chain_used (maskss
, 1);
2018 /* Generate the loop body. */
2019 gfc_start_scalarized_body (&loop
, &body
);
2021 /* If we have a mask, only check this element if the mask is set. */
2024 gfc_init_se (&maskse
, NULL
);
2025 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2027 gfc_conv_expr_val (&maskse
, maskexpr
);
2028 gfc_add_block_to_block (&body
, &maskse
.pre
);
2030 gfc_start_block (&block
);
2033 gfc_init_block (&block
);
2035 /* Compare with the current limit. */
2036 gfc_init_se (&arrayse
, NULL
);
2037 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2038 arrayse
.ss
= arrayss
;
2039 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2040 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2042 /* We do the following if this is a more extreme value. */
2043 gfc_start_block (&ifblock
);
2045 /* Assign the value to the limit... */
2046 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
2048 /* Remember where we are. */
2049 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
2051 ifbody
= gfc_finish_block (&ifblock
);
2053 /* If it is a more extreme value or pos is still zero. */
2054 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2055 build2 (op
, boolean_type_node
, arrayse
.expr
, limit
),
2056 build2 (EQ_EXPR
, boolean_type_node
, pos
, gfc_index_zero_node
));
2057 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2058 gfc_add_expr_to_block (&block
, tmp
);
2062 /* We enclose the above in if (mask) {...}. */
2063 tmp
= gfc_finish_block (&block
);
2065 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2068 tmp
= gfc_finish_block (&block
);
2069 gfc_add_expr_to_block (&body
, tmp
);
2071 gfc_trans_scalarizing_loops (&loop
, &body
);
2073 /* For a scalar mask, enclose the loop in an if statement. */
2074 if (maskexpr
&& maskss
== NULL
)
2076 gfc_init_se (&maskse
, NULL
);
2077 gfc_conv_expr_val (&maskse
, maskexpr
);
2078 gfc_init_block (&block
);
2079 gfc_add_block_to_block (&block
, &loop
.pre
);
2080 gfc_add_block_to_block (&block
, &loop
.post
);
2081 tmp
= gfc_finish_block (&block
);
2083 /* For the else part of the scalar mask, just initialize
2084 the pos variable the same way as above. */
2086 gfc_init_block (&elseblock
);
2087 gfc_add_modify_expr (&elseblock
, pos
, gfc_index_zero_node
);
2088 elsetmp
= gfc_finish_block (&elseblock
);
2090 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2091 gfc_add_expr_to_block (&block
, tmp
);
2092 gfc_add_block_to_block (&se
->pre
, &block
);
2096 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2097 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2099 gfc_cleanup_loop (&loop
);
2101 /* Return a value in the range 1..SIZE(array). */
2102 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
2103 gfc_index_one_node
);
2104 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
);
2105 /* And convert to the required type. */
2106 se
->expr
= convert (type
, tmp
);
2110 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
2119 gfc_actual_arglist
*actual
;
2124 gfc_expr
*arrayexpr
;
2130 gfc_conv_intrinsic_funcall (se
, expr
);
2134 type
= gfc_typenode_for_spec (&expr
->ts
);
2135 /* Initialize the result. */
2136 limit
= gfc_create_var (type
, "limit");
2137 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2138 switch (expr
->ts
.type
)
2141 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
2145 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2152 /* We start with the most negative possible value for MAXVAL, and the most
2153 positive possible value for MINVAL. The most negative possible value is
2154 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2155 possible value is HUGE in both cases. */
2157 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2159 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2160 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2161 build_int_cst (type
, 1));
2163 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
2165 /* Walk the arguments. */
2166 actual
= expr
->value
.function
.actual
;
2167 arrayexpr
= actual
->expr
;
2168 arrayss
= gfc_walk_expr (arrayexpr
);
2169 gcc_assert (arrayss
!= gfc_ss_terminator
);
2171 actual
= actual
->next
->next
;
2172 gcc_assert (actual
);
2173 maskexpr
= actual
->expr
;
2174 if (maskexpr
&& maskexpr
->rank
!= 0)
2176 maskss
= gfc_walk_expr (maskexpr
);
2177 gcc_assert (maskss
!= gfc_ss_terminator
);
2182 /* Initialize the scalarizer. */
2183 gfc_init_loopinfo (&loop
);
2184 gfc_add_ss_to_loop (&loop
, arrayss
);
2186 gfc_add_ss_to_loop (&loop
, maskss
);
2188 /* Initialize the loop. */
2189 gfc_conv_ss_startstride (&loop
);
2190 gfc_conv_loop_setup (&loop
);
2192 gfc_mark_ss_chain_used (arrayss
, 1);
2194 gfc_mark_ss_chain_used (maskss
, 1);
2195 /* Generate the loop body. */
2196 gfc_start_scalarized_body (&loop
, &body
);
2198 /* If we have a mask, only add this element if the mask is set. */
2201 gfc_init_se (&maskse
, NULL
);
2202 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2204 gfc_conv_expr_val (&maskse
, maskexpr
);
2205 gfc_add_block_to_block (&body
, &maskse
.pre
);
2207 gfc_start_block (&block
);
2210 gfc_init_block (&block
);
2212 /* Compare with the current limit. */
2213 gfc_init_se (&arrayse
, NULL
);
2214 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2215 arrayse
.ss
= arrayss
;
2216 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2217 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2219 /* Assign the value to the limit... */
2220 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2222 /* If it is a more extreme value. */
2223 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2224 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2225 gfc_add_expr_to_block (&block
, tmp
);
2226 gfc_add_block_to_block (&block
, &arrayse
.post
);
2228 tmp
= gfc_finish_block (&block
);
2230 /* We enclose the above in if (mask) {...}. */
2231 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2232 gfc_add_expr_to_block (&body
, tmp
);
2234 gfc_trans_scalarizing_loops (&loop
, &body
);
2236 /* For a scalar mask, enclose the loop in an if statement. */
2237 if (maskexpr
&& maskss
== NULL
)
2239 gfc_init_se (&maskse
, NULL
);
2240 gfc_conv_expr_val (&maskse
, maskexpr
);
2241 gfc_init_block (&block
);
2242 gfc_add_block_to_block (&block
, &loop
.pre
);
2243 gfc_add_block_to_block (&block
, &loop
.post
);
2244 tmp
= gfc_finish_block (&block
);
2246 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2247 gfc_add_expr_to_block (&block
, tmp
);
2248 gfc_add_block_to_block (&se
->pre
, &block
);
2252 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2253 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2256 gfc_cleanup_loop (&loop
);
2261 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2263 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2270 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2271 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2272 arg
= TREE_VALUE (arg
);
2273 type
= TREE_TYPE (arg
);
2275 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
2276 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
2277 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2278 build_int_cst (type
, 0));
2279 type
= gfc_typenode_for_spec (&expr
->ts
);
2280 se
->expr
= convert (type
, tmp
);
2283 /* Generate code to perform the specified operation. */
2285 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
2291 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2292 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2293 arg
= TREE_VALUE (arg
);
2294 type
= TREE_TYPE (arg
);
2296 se
->expr
= fold_build2 (op
, type
, arg
, arg2
);
2301 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2305 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2306 arg
= TREE_VALUE (arg
);
2308 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2311 /* Set or clear a single bit. */
2313 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2321 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2322 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2323 arg
= TREE_VALUE (arg
);
2324 type
= TREE_TYPE (arg
);
2326 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
2332 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2334 se
->expr
= fold_build2 (op
, type
, arg
, tmp
);
2337 /* Extract a sequence of bits.
2338 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2340 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2349 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2350 arg2
= TREE_CHAIN (arg
);
2351 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
2352 arg
= TREE_VALUE (arg
);
2353 arg2
= TREE_VALUE (arg2
);
2354 type
= TREE_TYPE (arg
);
2356 mask
= build_int_cst (type
, -1);
2357 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
2358 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
2360 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
2362 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2365 /* RSHIFT (I, SHIFT) = I >> SHIFT
2366 LSHIFT (I, SHIFT) = I << SHIFT */
2368 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
2373 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2374 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2375 arg
= TREE_VALUE (arg
);
2377 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
2378 TREE_TYPE (arg
), arg
, arg2
);
2381 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2383 : ((shift >= 0) ? i << shift : i >> -shift)
2384 where all shifts are logical shifts. */
2386 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2399 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2400 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2401 arg
= TREE_VALUE (arg
);
2402 type
= TREE_TYPE (arg
);
2403 utype
= gfc_unsigned_type (type
);
2405 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
);
2407 /* Left shift if positive. */
2408 lshift
= fold_build2 (LSHIFT_EXPR
, type
, arg
, width
);
2410 /* Right shift if negative.
2411 We convert to an unsigned type because we want a logical shift.
2412 The standard doesn't define the case of shifting negative
2413 numbers, and we try to be compatible with other compilers, most
2414 notably g77, here. */
2415 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
2416 convert (utype
, arg
), width
));
2418 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
,
2419 build_int_cst (TREE_TYPE (arg2
), 0));
2420 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2422 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2423 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2425 num_bits
= build_int_cst (TREE_TYPE (arg2
), TYPE_PRECISION (type
));
2426 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2428 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2429 build_int_cst (type
, 0), tmp
);
2432 /* Circular shift. AKA rotate or barrel shift. */
2434 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2445 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2446 arg2
= TREE_CHAIN (arg
);
2447 arg3
= TREE_CHAIN (arg2
);
2450 /* Use a library function for the 3 parameter version. */
2451 tree int4type
= gfc_get_int_type (4);
2453 type
= TREE_TYPE (TREE_VALUE (arg
));
2454 /* We convert the first argument to at least 4 bytes, and
2455 convert back afterwards. This removes the need for library
2456 functions for all argument sizes, and function will be
2457 aligned to at least 32 bits, so there's no loss. */
2458 if (expr
->ts
.kind
< 4)
2460 tmp
= convert (int4type
, TREE_VALUE (arg
));
2461 TREE_VALUE (arg
) = tmp
;
2463 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2464 need loads of library functions. They cannot have values >
2465 BIT_SIZE (I) so the conversion is safe. */
2466 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
2467 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
2469 switch (expr
->ts
.kind
)
2474 tmp
= gfor_fndecl_math_ishftc4
;
2477 tmp
= gfor_fndecl_math_ishftc8
;
2480 tmp
= gfor_fndecl_math_ishftc16
;
2485 se
->expr
= build_function_call_expr (tmp
, arg
);
2486 /* Convert the result back to the original type, if we extended
2487 the first argument's width above. */
2488 if (expr
->ts
.kind
< 4)
2489 se
->expr
= convert (type
, se
->expr
);
2493 arg
= TREE_VALUE (arg
);
2494 arg2
= TREE_VALUE (arg2
);
2495 type
= TREE_TYPE (arg
);
2497 /* Rotate left if positive. */
2498 lrot
= fold_build2 (LROTATE_EXPR
, type
, arg
, arg2
);
2500 /* Rotate right if negative. */
2501 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
2502 rrot
= fold_build2 (RROTATE_EXPR
, type
, arg
, tmp
);
2504 zero
= build_int_cst (TREE_TYPE (arg2
), 0);
2505 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
);
2506 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2508 /* Do nothing if shift == 0. */
2509 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg2
, zero
);
2510 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, arg
, rrot
);
2513 /* The length of a character string. */
2515 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2525 gcc_assert (!se
->ss
);
2527 arg
= expr
->value
.function
.actual
->expr
;
2529 type
= gfc_typenode_for_spec (&expr
->ts
);
2530 switch (arg
->expr_type
)
2533 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2537 /* Obtain the string length from the function used by
2538 trans-array.c(gfc_trans_array_constructor). */
2540 get_array_ctor_strlen (arg
->value
.constructor
, &len
);
2544 if (arg
->ref
== NULL
2545 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
2547 /* This doesn't catch all cases.
2548 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2549 and the surrounding thread. */
2550 sym
= arg
->symtree
->n
.sym
;
2551 decl
= gfc_get_symbol_decl (sym
);
2552 if (decl
== current_function_decl
&& sym
->attr
.function
2553 && (sym
->result
== sym
))
2554 decl
= gfc_get_fake_result_decl (sym
, 0);
2556 len
= sym
->ts
.cl
->backend_decl
;
2561 /* Otherwise fall through. */
2564 /* Anybody stupid enough to do this deserves inefficient code. */
2565 ss
= gfc_walk_expr (arg
);
2566 gfc_init_se (&argse
, se
);
2567 if (ss
== gfc_ss_terminator
)
2568 gfc_conv_expr (&argse
, arg
);
2570 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2571 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2572 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2573 len
= argse
.string_length
;
2576 se
->expr
= convert (type
, len
);
2579 /* The length of a character string not including trailing blanks. */
2581 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2586 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2587 type
= gfc_typenode_for_spec (&expr
->ts
);
2588 se
->expr
= build_function_call_expr (gfor_fndecl_string_len_trim
, args
);
2589 se
->expr
= convert (type
, se
->expr
);
2593 /* Returns the starting position of a substring within a string. */
2596 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
2598 tree logical4_type_node
= gfc_get_logical_type (4);
2604 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2605 type
= gfc_typenode_for_spec (&expr
->ts
);
2606 tmp
= gfc_advance_chain (args
, 3);
2607 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2609 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2611 TREE_CHAIN (tmp
) = back
;
2615 back
= TREE_CHAIN (tmp
);
2616 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2619 se
->expr
= build_function_call_expr (gfor_fndecl_string_index
, args
);
2620 se
->expr
= convert (type
, se
->expr
);
2623 /* The ascii value for a single character. */
2625 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2630 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2631 arg
= TREE_VALUE (TREE_CHAIN (arg
));
2632 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
2633 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
2634 type
= gfc_typenode_for_spec (&expr
->ts
);
2636 se
->expr
= build_fold_indirect_ref (arg
);
2637 se
->expr
= convert (type
, se
->expr
);
2641 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2644 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2653 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2654 if (expr
->ts
.type
!= BT_CHARACTER
)
2656 tsource
= TREE_VALUE (arg
);
2657 arg
= TREE_CHAIN (arg
);
2658 fsource
= TREE_VALUE (arg
);
2659 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2663 /* We do the same as in the non-character case, but the argument
2664 list is different because of the string length arguments. We
2665 also have to set the string length for the result. */
2666 len
= TREE_VALUE (arg
);
2667 arg
= TREE_CHAIN (arg
);
2668 tsource
= TREE_VALUE (arg
);
2669 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2670 fsource
= TREE_VALUE (arg
);
2671 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2673 se
->string_length
= len
;
2675 type
= TREE_TYPE (tsource
);
2676 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2681 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2683 gfc_actual_arglist
*actual
;
2691 gfc_init_se (&argse
, NULL
);
2692 actual
= expr
->value
.function
.actual
;
2694 ss
= gfc_walk_expr (actual
->expr
);
2695 gcc_assert (ss
!= gfc_ss_terminator
);
2696 argse
.want_pointer
= 1;
2697 argse
.data_not_needed
= 1;
2698 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2699 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2700 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2701 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2703 /* Build the call to size0. */
2704 fncall0
= build_call_expr (gfor_fndecl_size0
, 1, arg1
);
2706 actual
= actual
->next
;
2710 gfc_init_se (&argse
, NULL
);
2711 gfc_conv_expr_type (&argse
, actual
->expr
,
2712 gfc_array_index_type
);
2713 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2715 /* Build the call to size1. */
2716 fncall1
= build_call_expr (gfor_fndecl_size1
, 2,
2719 /* Unusually, for an intrinsic, size does not exclude
2720 an optional arg2, so we must test for it. */
2721 if (actual
->expr
->expr_type
== EXPR_VARIABLE
2722 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
2723 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
2726 gfc_init_se (&argse
, NULL
);
2727 argse
.want_pointer
= 1;
2728 argse
.data_not_needed
= 1;
2729 gfc_conv_expr (&argse
, actual
->expr
);
2730 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2731 tmp
= build2 (NE_EXPR
, boolean_type_node
, argse
.expr
,
2733 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2734 se
->expr
= build3 (COND_EXPR
, pvoid_type_node
,
2735 tmp
, fncall1
, fncall0
);
2743 type
= gfc_typenode_for_spec (&expr
->ts
);
2744 se
->expr
= convert (type
, se
->expr
);
2748 /* Intrinsic string comparison functions. */
2751 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2757 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2758 arg2
= TREE_CHAIN (TREE_CHAIN (args
));
2760 se
->expr
= gfc_build_compare_string (TREE_VALUE (args
),
2761 TREE_VALUE (TREE_CHAIN (args
)), TREE_VALUE (arg2
),
2762 TREE_VALUE (TREE_CHAIN (arg2
)));
2764 type
= gfc_typenode_for_spec (&expr
->ts
);
2765 se
->expr
= fold_build2 (op
, type
, se
->expr
,
2766 build_int_cst (TREE_TYPE (se
->expr
), 0));
2769 /* Generate a call to the adjustl/adjustr library function. */
2771 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2779 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2780 len
= TREE_VALUE (args
);
2782 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2783 var
= gfc_conv_string_tmp (se
, type
, len
);
2784 args
= tree_cons (NULL_TREE
, var
, args
);
2786 tmp
= build_function_call_expr (fndecl
, args
);
2787 gfc_add_expr_to_block (&se
->pre
, tmp
);
2789 se
->string_length
= len
;
2793 /* A helper function for gfc_conv_intrinsic_array_transfer to compute
2794 the size of tree expressions in bytes. */
2796 gfc_size_in_bytes (gfc_se
*se
, gfc_expr
*e
)
2800 if (e
->ts
.type
== BT_CHARACTER
)
2801 tmp
= se
->string_length
;
2806 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
2807 tmp
= size_in_bytes (tmp
);
2810 tmp
= size_in_bytes (TREE_TYPE (TREE_TYPE (se
->expr
)));
2813 return fold_convert (gfc_array_index_type
, tmp
);
2817 /* Array transfer statement.
2818 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2820 typeof<DEST> = typeof<MOLD>
2822 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2823 sizeof (DEST(0) * SIZE). */
2826 gfc_conv_intrinsic_array_transfer (gfc_se
* se
, gfc_expr
* expr
)
2839 gfc_actual_arglist
*arg
;
2846 gcc_assert (se
->loop
);
2847 info
= &se
->ss
->data
.info
;
2849 /* Convert SOURCE. The output from this stage is:-
2850 source_bytes = length of the source in bytes
2851 source = pointer to the source data. */
2852 arg
= expr
->value
.function
.actual
;
2853 gfc_init_se (&argse
, NULL
);
2854 ss
= gfc_walk_expr (arg
->expr
);
2856 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
2858 /* Obtain the pointer to source and the length of source in bytes. */
2859 if (ss
== gfc_ss_terminator
)
2861 gfc_conv_expr_reference (&argse
, arg
->expr
);
2862 source
= argse
.expr
;
2864 /* Obtain the source word length. */
2865 tmp
= gfc_size_in_bytes (&argse
, arg
->expr
);
2869 gfc_init_se (&argse
, NULL
);
2870 argse
.want_pointer
= 0;
2871 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
2872 source
= gfc_conv_descriptor_data_get (argse
.expr
);
2874 /* Repack the source if not a full variable array. */
2875 if (!(arg
->expr
->expr_type
== EXPR_VARIABLE
2876 && arg
->expr
->ref
->u
.ar
.type
== AR_FULL
))
2878 tmp
= build_fold_addr_expr (argse
.expr
);
2879 source
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
2880 source
= gfc_evaluate_now (source
, &argse
.pre
);
2882 /* Free the temporary. */
2883 gfc_start_block (&block
);
2884 tmp
= convert (pvoid_type_node
, source
);
2885 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, tmp
);
2886 gfc_add_expr_to_block (&block
, tmp
);
2887 stmt
= gfc_finish_block (&block
);
2889 /* Clean up if it was repacked. */
2890 gfc_init_block (&block
);
2891 tmp
= gfc_conv_array_data (argse
.expr
);
2892 tmp
= build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
2893 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
2894 gfc_add_expr_to_block (&block
, tmp
);
2895 gfc_add_block_to_block (&block
, &se
->post
);
2896 gfc_init_block (&se
->post
);
2897 gfc_add_block_to_block (&se
->post
, &block
);
2900 /* Obtain the source word length. */
2901 tmp
= gfc_size_in_bytes (&argse
, arg
->expr
);
2903 /* Obtain the size of the array in bytes. */
2904 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
2905 for (n
= 0; n
< arg
->expr
->rank
; n
++)
2908 idx
= gfc_rank_cst
[n
];
2909 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2910 stride
= gfc_conv_descriptor_stride (argse
.expr
, idx
);
2911 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
2912 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
2913 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2915 gfc_add_modify_expr (&argse
.pre
, extent
, tmp
);
2916 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2917 extent
, gfc_index_one_node
);
2918 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
,
2923 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2924 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2925 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2927 /* Now convert MOLD. The sole output is:
2928 dest_word_len = destination word length in bytes. */
2931 gfc_init_se (&argse
, NULL
);
2932 ss
= gfc_walk_expr (arg
->expr
);
2934 if (ss
== gfc_ss_terminator
)
2936 gfc_conv_expr_reference (&argse
, arg
->expr
);
2938 /* Obtain the source word length. */
2939 tmp
= gfc_size_in_bytes (&argse
, arg
->expr
);
2943 gfc_init_se (&argse
, NULL
);
2944 argse
.want_pointer
= 0;
2945 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
2947 /* Obtain the source word length. */
2948 tmp
= gfc_size_in_bytes (&argse
, arg
->expr
);
2951 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
2952 gfc_add_modify_expr (&se
->pre
, dest_word_len
, tmp
);
2954 /* Finally convert SIZE, if it is present. */
2956 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
2960 gfc_init_se (&argse
, NULL
);
2961 gfc_conv_expr_reference (&argse
, arg
->expr
);
2962 tmp
= convert (gfc_array_index_type
,
2963 build_fold_indirect_ref (argse
.expr
));
2964 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2965 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2970 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
2971 if (tmp
!= NULL_TREE
)
2973 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
,
2974 tmp
, dest_word_len
);
2975 tmp
= build2 (MIN_EXPR
, gfc_array_index_type
, tmp
, source_bytes
);
2980 gfc_add_modify_expr (&se
->pre
, size_bytes
, tmp
);
2981 gfc_add_modify_expr (&se
->pre
, size_words
,
2982 build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
2983 size_bytes
, dest_word_len
));
2985 /* Evaluate the bounds of the result. If the loop range exists, we have
2986 to check if it is too large. If so, we modify loop->to be consistent
2987 with min(size, size(source)). Otherwise, size is made consistent with
2988 the loop range, so that the right number of bytes is transferred.*/
2989 n
= se
->loop
->order
[0];
2990 if (se
->loop
->to
[n
] != NULL_TREE
)
2992 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2993 se
->loop
->to
[n
], se
->loop
->from
[n
]);
2994 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2995 tmp
, gfc_index_one_node
);
2996 tmp
= build2 (MIN_EXPR
, gfc_array_index_type
,
2998 gfc_add_modify_expr (&se
->pre
, size_words
, tmp
);
2999 gfc_add_modify_expr (&se
->pre
, size_bytes
,
3000 build2 (MULT_EXPR
, gfc_array_index_type
,
3001 size_words
, dest_word_len
));
3002 upper
= build2 (PLUS_EXPR
, gfc_array_index_type
,
3003 size_words
, se
->loop
->from
[n
]);
3004 upper
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3005 upper
, gfc_index_one_node
);
3009 upper
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3010 size_words
, gfc_index_one_node
);
3011 se
->loop
->from
[n
] = gfc_index_zero_node
;
3014 se
->loop
->to
[n
] = upper
;
3016 /* Build a destination descriptor, using the pointer, source, as the
3017 data field. This is already allocated so set callee_alloc.
3018 FIXME callee_alloc is not set! */
3020 tmp
= gfc_typenode_for_spec (&expr
->ts
);
3021 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
3022 info
, tmp
, false, true, false);
3024 /* Use memcpy to do the transfer. */
3025 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
],
3027 gfc_conv_descriptor_data_get (info
->descriptor
),
3028 fold_convert (pvoid_type_node
, source
),
3030 gfc_add_expr_to_block (&se
->pre
, tmp
);
3032 se
->expr
= info
->descriptor
;
3033 if (expr
->ts
.type
== BT_CHARACTER
)
3034 se
->string_length
= dest_word_len
;
3038 /* Scalar transfer statement.
3039 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3042 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
3044 gfc_actual_arglist
*arg
;
3051 /* Get a pointer to the source. */
3052 arg
= expr
->value
.function
.actual
;
3053 ss
= gfc_walk_expr (arg
->expr
);
3054 gfc_init_se (&argse
, NULL
);
3055 if (ss
== gfc_ss_terminator
)
3056 gfc_conv_expr_reference (&argse
, arg
->expr
);
3058 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
3059 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3060 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3064 type
= gfc_typenode_for_spec (&expr
->ts
);
3066 if (expr
->ts
.type
== BT_CHARACTER
)
3068 ptr
= convert (build_pointer_type (type
), ptr
);
3069 gfc_init_se (&argse
, NULL
);
3070 gfc_conv_expr (&argse
, arg
->expr
);
3071 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3072 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3074 se
->string_length
= argse
.string_length
;
3079 tmpdecl
= gfc_create_var (type
, "transfer");
3080 moldsize
= size_in_bytes (type
);
3082 /* Use memcpy to do the transfer. */
3083 tmp
= build1 (ADDR_EXPR
, build_pointer_type (type
), tmpdecl
);
3084 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
3085 fold_convert (pvoid_type_node
, tmp
),
3086 fold_convert (pvoid_type_node
, ptr
),
3088 gfc_add_expr_to_block (&se
->pre
, tmp
);
3095 /* Generate code for the ALLOCATED intrinsic.
3096 Generate inline code that directly check the address of the argument. */
3099 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
3101 gfc_actual_arglist
*arg1
;
3106 gfc_init_se (&arg1se
, NULL
);
3107 arg1
= expr
->value
.function
.actual
;
3108 ss1
= gfc_walk_expr (arg1
->expr
);
3109 arg1se
.descriptor_only
= 1;
3110 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3112 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3113 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
3114 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
3115 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
3119 /* Generate code for the ASSOCIATED intrinsic.
3120 If both POINTER and TARGET are arrays, generate a call to library function
3121 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3122 In other cases, generate inline code that directly compare the address of
3123 POINTER with the address of TARGET. */
3126 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
3128 gfc_actual_arglist
*arg1
;
3129 gfc_actual_arglist
*arg2
;
3135 tree nonzero_charlen
;
3136 tree nonzero_arraylen
;
3139 gfc_init_se (&arg1se
, NULL
);
3140 gfc_init_se (&arg2se
, NULL
);
3141 arg1
= expr
->value
.function
.actual
;
3143 ss1
= gfc_walk_expr (arg1
->expr
);
3147 /* No optional target. */
3148 if (ss1
== gfc_ss_terminator
)
3150 /* A pointer to a scalar. */
3151 arg1se
.want_pointer
= 1;
3152 gfc_conv_expr (&arg1se
, arg1
->expr
);
3157 /* A pointer to an array. */
3158 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3159 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3161 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3162 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3163 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
3164 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
3169 /* An optional target. */
3170 ss2
= gfc_walk_expr (arg2
->expr
);
3172 nonzero_charlen
= NULL_TREE
;
3173 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
3174 nonzero_charlen
= build2 (NE_EXPR
, boolean_type_node
,
3175 arg1
->expr
->ts
.cl
->backend_decl
,
3178 if (ss1
== gfc_ss_terminator
)
3180 /* A pointer to a scalar. */
3181 gcc_assert (ss2
== gfc_ss_terminator
);
3182 arg1se
.want_pointer
= 1;
3183 gfc_conv_expr (&arg1se
, arg1
->expr
);
3184 arg2se
.want_pointer
= 1;
3185 gfc_conv_expr (&arg2se
, arg2
->expr
);
3186 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3187 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3188 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
3189 tmp2
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
3191 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, tmp
, tmp2
);
3196 /* An array pointer of zero length is not associated if target is
3198 arg1se
.descriptor_only
= 1;
3199 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
3200 tmp
= gfc_conv_descriptor_stride (arg1se
.expr
,
3201 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
3202 nonzero_arraylen
= build2 (NE_EXPR
, boolean_type_node
,
3203 tmp
, integer_zero_node
);
3205 /* A pointer to an array, call library function _gfor_associated. */
3206 gcc_assert (ss2
!= gfc_ss_terminator
);
3207 arg1se
.want_pointer
= 1;
3208 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3210 arg2se
.want_pointer
= 1;
3211 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
3212 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3213 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3214 fndecl
= gfor_fndecl_associated
;
3215 se
->expr
= build_call_expr (fndecl
, 2, arg1se
.expr
, arg2se
.expr
);
3216 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3217 se
->expr
, nonzero_arraylen
);
3221 /* If target is present zero character length pointers cannot
3223 if (nonzero_charlen
!= NULL_TREE
)
3224 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3225 se
->expr
, nonzero_charlen
);
3228 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3232 /* Scan a string for any one of the characters in a set of characters. */
3235 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
3237 tree logical4_type_node
= gfc_get_logical_type (4);
3243 args
= gfc_conv_intrinsic_function_args (se
, expr
);
3244 type
= gfc_typenode_for_spec (&expr
->ts
);
3245 tmp
= gfc_advance_chain (args
, 3);
3246 if (TREE_CHAIN (tmp
) == NULL_TREE
)
3248 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
3250 TREE_CHAIN (tmp
) = back
;
3254 back
= TREE_CHAIN (tmp
);
3255 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
3258 se
->expr
= build_function_call_expr (gfor_fndecl_string_scan
, args
);
3259 se
->expr
= convert (type
, se
->expr
);
3263 /* Verify that a set of characters contains all the characters in a string
3264 by identifying the position of the first character in a string of
3265 characters that does not appear in a given set of characters. */
3268 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
3270 tree logical4_type_node
= gfc_get_logical_type (4);
3276 args
= gfc_conv_intrinsic_function_args (se
, expr
);
3277 type
= gfc_typenode_for_spec (&expr
->ts
);
3278 tmp
= gfc_advance_chain (args
, 3);
3279 if (TREE_CHAIN (tmp
) == NULL_TREE
)
3281 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
3283 TREE_CHAIN (tmp
) = back
;
3287 back
= TREE_CHAIN (tmp
);
3288 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
3291 se
->expr
= build_function_call_expr (gfor_fndecl_string_verify
, args
);
3292 se
->expr
= convert (type
, se
->expr
);
3296 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3299 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
3303 args
= gfc_conv_intrinsic_function_args (se
, expr
);
3304 args
= TREE_VALUE (args
);
3305 args
= build_fold_addr_expr (args
);
3306 se
->expr
= build_call_expr (gfor_fndecl_si_kind
, 1, args
);
3309 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3312 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
3314 gfc_actual_arglist
*actual
;
3319 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3321 gfc_init_se (&argse
, se
);
3323 /* Pass a NULL pointer for an absent arg. */
3324 if (actual
->expr
== NULL
)
3325 argse
.expr
= null_pointer_node
;
3327 gfc_conv_expr_reference (&argse
, actual
->expr
);
3329 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3330 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3331 args
= gfc_chainon_list (args
, argse
.expr
);
3333 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
3337 /* Generate code for TRIM (A) intrinsic function. */
3340 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
3342 tree gfc_int4_type_node
= gfc_get_int_type (4);
3351 arglist
= NULL_TREE
;
3353 type
= build_pointer_type (gfc_character1_type_node
);
3354 var
= gfc_create_var (type
, "pstr");
3355 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
3356 len
= gfc_create_var (gfc_int4_type_node
, "len");
3358 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
3359 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
3360 arglist
= gfc_chainon_list (arglist
, addr
);
3361 arglist
= chainon (arglist
, tmp
);
3363 tmp
= build_function_call_expr (gfor_fndecl_string_trim
, arglist
);
3364 gfc_add_expr_to_block (&se
->pre
, tmp
);
3366 /* Free the temporary afterwards, if necessary. */
3367 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
3368 build_int_cst (TREE_TYPE (len
), 0));
3369 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, var
);
3370 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
3371 gfc_add_expr_to_block (&se
->post
, tmp
);
3374 se
->string_length
= len
;
3378 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3381 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
3383 tree gfc_int4_type_node
= gfc_get_int_type (4);
3392 args
= gfc_conv_intrinsic_function_args (se
, expr
);
3393 len
= TREE_VALUE (args
);
3394 tmp
= gfc_advance_chain (args
, 2);
3395 ncopies
= TREE_VALUE (tmp
);
3397 /* Check that ncopies is not negative. */
3398 ncopies
= gfc_evaluate_now (ncopies
, &se
->pre
);
3399 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
3400 build_int_cst (TREE_TYPE (ncopies
), 0));
3401 gfc_trans_runtime_check (cond
,
3402 "Argument NCOPIES of REPEAT intrinsic is negative",
3403 &se
->pre
, &expr
->where
);
3405 /* Compute the destination length. */
3406 len
= fold_build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
);
3407 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
3408 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
3410 /* Create the argument list and generate the function call. */
3411 tmp
= build_call_expr (gfor_fndecl_string_repeat
, 4, var
,
3413 TREE_VALUE (TREE_CHAIN (args
)), ncopies
);
3414 gfc_add_expr_to_block (&se
->pre
, tmp
);
3417 se
->string_length
= len
;
3421 /* Generate code for the IARGC intrinsic. */
3424 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
3430 /* Call the library function. This always returns an INTEGER(4). */
3431 fndecl
= gfor_fndecl_iargc
;
3432 tmp
= build_call_expr (fndecl
, 0);
3434 /* Convert it to the required type. */
3435 type
= gfc_typenode_for_spec (&expr
->ts
);
3436 tmp
= fold_convert (type
, tmp
);
3442 /* The loc intrinsic returns the address of its argument as
3443 gfc_index_integer_kind integer. */
3446 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
3452 gcc_assert (!se
->ss
);
3454 arg_expr
= expr
->value
.function
.actual
->expr
;
3455 ss
= gfc_walk_expr (arg_expr
);
3456 if (ss
== gfc_ss_terminator
)
3457 gfc_conv_expr_reference (se
, arg_expr
);
3459 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1);
3460 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
3462 /* Create a temporary variable for loc return value. Without this,
3463 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
3464 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
3465 gfc_add_modify_expr (&se
->pre
, temp_var
, se
->expr
);
3466 se
->expr
= temp_var
;
3469 /* Generate code for an intrinsic function. Some map directly to library
3470 calls, others get special handling. In some cases the name of the function
3471 used depends on the type specifiers. */
3474 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
3476 gfc_intrinsic_sym
*isym
;
3480 isym
= expr
->value
.function
.isym
;
3482 name
= &expr
->value
.function
.name
[2];
3484 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
3486 lib
= gfc_is_intrinsic_libcall (expr
);
3490 se
->ignore_optional
= 1;
3491 gfc_conv_intrinsic_funcall (se
, expr
);
3496 switch (expr
->value
.function
.isym
->generic_id
)
3501 case GFC_ISYM_REPEAT
:
3502 gfc_conv_intrinsic_repeat (se
, expr
);
3506 gfc_conv_intrinsic_trim (se
, expr
);
3509 case GFC_ISYM_SI_KIND
:
3510 gfc_conv_intrinsic_si_kind (se
, expr
);
3513 case GFC_ISYM_SR_KIND
:
3514 gfc_conv_intrinsic_sr_kind (se
, expr
);
3517 case GFC_ISYM_EXPONENT
:
3518 gfc_conv_intrinsic_exponent (se
, expr
);
3522 gfc_conv_intrinsic_scan (se
, expr
);
3525 case GFC_ISYM_VERIFY
:
3526 gfc_conv_intrinsic_verify (se
, expr
);
3529 case GFC_ISYM_ALLOCATED
:
3530 gfc_conv_allocated (se
, expr
);
3533 case GFC_ISYM_ASSOCIATED
:
3534 gfc_conv_associated(se
, expr
);
3538 gfc_conv_intrinsic_abs (se
, expr
);
3541 case GFC_ISYM_ADJUSTL
:
3542 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
3545 case GFC_ISYM_ADJUSTR
:
3546 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
3549 case GFC_ISYM_AIMAG
:
3550 gfc_conv_intrinsic_imagpart (se
, expr
);
3554 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
3558 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
3561 case GFC_ISYM_ANINT
:
3562 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
3566 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3570 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
3573 case GFC_ISYM_BTEST
:
3574 gfc_conv_intrinsic_btest (se
, expr
);
3577 case GFC_ISYM_ACHAR
:
3579 gfc_conv_intrinsic_char (se
, expr
);
3582 case GFC_ISYM_CONVERSION
:
3584 case GFC_ISYM_LOGICAL
:
3586 gfc_conv_intrinsic_conversion (se
, expr
);
3589 /* Integer conversions are handled separately to make sure we get the
3590 correct rounding mode. */
3595 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
3599 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
3602 case GFC_ISYM_CEILING
:
3603 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
3606 case GFC_ISYM_FLOOR
:
3607 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
3611 gfc_conv_intrinsic_mod (se
, expr
, 0);
3614 case GFC_ISYM_MODULO
:
3615 gfc_conv_intrinsic_mod (se
, expr
, 1);
3618 case GFC_ISYM_CMPLX
:
3619 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
3622 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
3623 gfc_conv_intrinsic_iargc (se
, expr
);
3626 case GFC_ISYM_COMPLEX
:
3627 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
3630 case GFC_ISYM_CONJG
:
3631 gfc_conv_intrinsic_conjg (se
, expr
);
3634 case GFC_ISYM_COUNT
:
3635 gfc_conv_intrinsic_count (se
, expr
);
3638 case GFC_ISYM_CTIME
:
3639 gfc_conv_intrinsic_ctime (se
, expr
);
3643 gfc_conv_intrinsic_dim (se
, expr
);
3646 case GFC_ISYM_DOT_PRODUCT
:
3647 gfc_conv_intrinsic_dot_product (se
, expr
);
3650 case GFC_ISYM_DPROD
:
3651 gfc_conv_intrinsic_dprod (se
, expr
);
3654 case GFC_ISYM_FDATE
:
3655 gfc_conv_intrinsic_fdate (se
, expr
);
3659 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3662 case GFC_ISYM_IBCLR
:
3663 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
3666 case GFC_ISYM_IBITS
:
3667 gfc_conv_intrinsic_ibits (se
, expr
);
3670 case GFC_ISYM_IBSET
:
3671 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
3674 case GFC_ISYM_IACHAR
:
3675 case GFC_ISYM_ICHAR
:
3676 /* We assume ASCII character sequence. */
3677 gfc_conv_intrinsic_ichar (se
, expr
);
3680 case GFC_ISYM_IARGC
:
3681 gfc_conv_intrinsic_iargc (se
, expr
);
3685 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3688 case GFC_ISYM_INDEX
:
3689 gfc_conv_intrinsic_index (se
, expr
);
3693 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3696 case GFC_ISYM_LSHIFT
:
3697 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
3700 case GFC_ISYM_RSHIFT
:
3701 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
3704 case GFC_ISYM_ISHFT
:
3705 gfc_conv_intrinsic_ishft (se
, expr
);
3708 case GFC_ISYM_ISHFTC
:
3709 gfc_conv_intrinsic_ishftc (se
, expr
);
3712 case GFC_ISYM_LBOUND
:
3713 gfc_conv_intrinsic_bound (se
, expr
, 0);
3716 case GFC_ISYM_TRANSPOSE
:
3717 if (se
->ss
&& se
->ss
->useflags
)
3719 gfc_conv_tmp_array_ref (se
);
3720 gfc_advance_se_ss_chain (se
);
3723 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
3727 gfc_conv_intrinsic_len (se
, expr
);
3730 case GFC_ISYM_LEN_TRIM
:
3731 gfc_conv_intrinsic_len_trim (se
, expr
);
3735 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
3739 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
3743 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
3747 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
3751 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
3754 case GFC_ISYM_MAXLOC
:
3755 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
3758 case GFC_ISYM_MAXVAL
:
3759 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
3762 case GFC_ISYM_MERGE
:
3763 gfc_conv_intrinsic_merge (se
, expr
);
3767 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
3770 case GFC_ISYM_MINLOC
:
3771 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
3774 case GFC_ISYM_MINVAL
:
3775 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
3779 gfc_conv_intrinsic_not (se
, expr
);
3783 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3786 case GFC_ISYM_PRESENT
:
3787 gfc_conv_intrinsic_present (se
, expr
);
3790 case GFC_ISYM_PRODUCT
:
3791 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
3795 gfc_conv_intrinsic_sign (se
, expr
);
3799 gfc_conv_intrinsic_size (se
, expr
);
3803 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
3806 case GFC_ISYM_TRANSFER
:
3809 if (se
->ss
->useflags
)
3811 /* Access the previously obtained result. */
3812 gfc_conv_tmp_array_ref (se
);
3813 gfc_advance_se_ss_chain (se
);
3817 gfc_conv_intrinsic_array_transfer (se
, expr
);
3820 gfc_conv_intrinsic_transfer (se
, expr
);
3823 case GFC_ISYM_TTYNAM
:
3824 gfc_conv_intrinsic_ttynam (se
, expr
);
3827 case GFC_ISYM_UBOUND
:
3828 gfc_conv_intrinsic_bound (se
, expr
, 1);
3832 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3836 gfc_conv_intrinsic_loc (se
, expr
);
3839 case GFC_ISYM_ACCESS
:
3840 case GFC_ISYM_CHDIR
:
3841 case GFC_ISYM_CHMOD
:
3842 case GFC_ISYM_ETIME
:
3844 case GFC_ISYM_FGETC
:
3847 case GFC_ISYM_FPUTC
:
3848 case GFC_ISYM_FSTAT
:
3849 case GFC_ISYM_FTELL
:
3850 case GFC_ISYM_GETCWD
:
3851 case GFC_ISYM_GETGID
:
3852 case GFC_ISYM_GETPID
:
3853 case GFC_ISYM_GETUID
:
3854 case GFC_ISYM_HOSTNM
:
3856 case GFC_ISYM_IERRNO
:
3857 case GFC_ISYM_IRAND
:
3858 case GFC_ISYM_ISATTY
:
3860 case GFC_ISYM_LSTAT
:
3861 case GFC_ISYM_MALLOC
:
3862 case GFC_ISYM_MATMUL
:
3863 case GFC_ISYM_MCLOCK
:
3864 case GFC_ISYM_MCLOCK8
:
3866 case GFC_ISYM_RENAME
:
3867 case GFC_ISYM_SECOND
:
3868 case GFC_ISYM_SECNDS
:
3869 case GFC_ISYM_SIGNAL
:
3871 case GFC_ISYM_SYMLNK
:
3872 case GFC_ISYM_SYSTEM
:
3874 case GFC_ISYM_TIME8
:
3875 case GFC_ISYM_UMASK
:
3876 case GFC_ISYM_UNLINK
:
3877 gfc_conv_intrinsic_funcall (se
, expr
);
3881 gfc_conv_intrinsic_lib_function (se
, expr
);
3887 /* This generates code to execute before entering the scalarization loop.
3888 Currently does nothing. */
3891 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3893 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3895 case GFC_ISYM_UBOUND
:
3896 case GFC_ISYM_LBOUND
:
3905 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3906 inside the scalarization loop. */
3909 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3913 /* The two argument version returns a scalar. */
3914 if (expr
->value
.function
.actual
->next
->expr
)
3917 newss
= gfc_get_ss ();
3918 newss
->type
= GFC_SS_INTRINSIC
;
3921 newss
->data
.info
.dimen
= 1;
3927 /* Walk an intrinsic array libcall. */
3930 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3934 gcc_assert (expr
->rank
> 0);
3936 newss
= gfc_get_ss ();
3937 newss
->type
= GFC_SS_FUNCTION
;
3940 newss
->data
.info
.dimen
= expr
->rank
;
3946 /* Returns nonzero if the specified intrinsic function call maps directly to a
3947 an external library call. Should only be used for functions that return
3951 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3953 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3954 gcc_assert (expr
->rank
> 0);
3956 switch (expr
->value
.function
.isym
->generic_id
)
3960 case GFC_ISYM_COUNT
:
3961 case GFC_ISYM_MATMUL
:
3962 case GFC_ISYM_MAXLOC
:
3963 case GFC_ISYM_MAXVAL
:
3964 case GFC_ISYM_MINLOC
:
3965 case GFC_ISYM_MINVAL
:
3966 case GFC_ISYM_PRODUCT
:
3968 case GFC_ISYM_SHAPE
:
3969 case GFC_ISYM_SPREAD
:
3970 case GFC_ISYM_TRANSPOSE
:
3971 /* Ignore absent optional parameters. */
3974 case GFC_ISYM_RESHAPE
:
3975 case GFC_ISYM_CSHIFT
:
3976 case GFC_ISYM_EOSHIFT
:
3978 case GFC_ISYM_UNPACK
:
3979 /* Pass absent optional parameters. */
3987 /* Walk an intrinsic function. */
3989 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3990 gfc_intrinsic_sym
* isym
)
3994 if (isym
->elemental
)
3995 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
3997 if (expr
->rank
== 0)
4000 if (gfc_is_intrinsic_libcall (expr
))
4001 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4003 /* Special cases. */
4004 switch (isym
->generic_id
)
4006 case GFC_ISYM_LBOUND
:
4007 case GFC_ISYM_UBOUND
:
4008 return gfc_walk_intrinsic_bound (ss
, expr
);
4010 case GFC_ISYM_TRANSFER
:
4011 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4014 /* This probably meant someone forgot to add an intrinsic to the above
4015 list(s) when they implemented it, or something's gone horribly wrong.
4017 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4018 expr
->value
.function
.name
);
4022 #include "gt-fortran-trans-intrinsic.h"