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 3, 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 COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #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. */
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. The value
167 of NARGS may be less than the actual number of arguments in EXPR
168 to allow optional "KIND" arguments that are not included in the
169 generated code to be ignored. */
172 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
173 tree
*argarray
, int nargs
)
175 gfc_actual_arglist
*actual
;
177 gfc_intrinsic_arg
*formal
;
181 formal
= expr
->value
.function
.isym
->formal
;
182 actual
= expr
->value
.function
.actual
;
184 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
185 actual
= actual
->next
,
186 formal
= formal
? formal
->next
: NULL
)
190 /* Skip omitted optional arguments. */
197 /* Evaluate the parameter. This will substitute scalarized
198 references automatically. */
199 gfc_init_se (&argse
, se
);
201 if (e
->ts
.type
== BT_CHARACTER
)
203 gfc_conv_expr (&argse
, e
);
204 gfc_conv_string_parameter (&argse
);
205 argarray
[curr_arg
++] = argse
.string_length
;
206 gcc_assert (curr_arg
< nargs
);
209 gfc_conv_expr_val (&argse
, e
);
211 /* If an optional argument is itself an optional dummy argument,
212 check its presence and substitute a null if absent. */
213 if (e
->expr_type
== EXPR_VARIABLE
214 && e
->symtree
->n
.sym
->attr
.optional
217 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
219 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
220 gfc_add_block_to_block (&se
->post
, &argse
.post
);
221 argarray
[curr_arg
] = argse
.expr
;
225 /* Count the number of actual arguments to the intrinsic function EXPR
226 including any "hidden" string length arguments. */
229 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
232 gfc_actual_arglist
*actual
;
234 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
239 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
249 /* Conversions between different types are output by the frontend as
250 intrinsic functions. We implement these directly with inline code. */
253 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
259 nargs
= gfc_intrinsic_argument_list_length (expr
);
260 args
= alloca (sizeof (tree
) * nargs
);
262 /* Evaluate all the arguments passed. Whilst we're only interested in the
263 first one here, there are other parts of the front-end that assume this
264 and will trigger an ICE if it's not the case. */
265 type
= gfc_typenode_for_spec (&expr
->ts
);
266 gcc_assert (expr
->value
.function
.actual
->expr
);
267 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
269 /* Conversion from complex to non-complex involves taking the real
270 component of the value. */
271 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
272 && expr
->ts
.type
!= BT_COMPLEX
)
276 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
277 args
[0] = build1 (REALPART_EXPR
, artype
, args
[0]);
280 se
->expr
= convert (type
, args
[0]);
283 /* This is needed because the gcc backend only implements
284 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
285 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
286 Similarly for CEILING. */
289 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
296 argtype
= TREE_TYPE (arg
);
297 arg
= gfc_evaluate_now (arg
, pblock
);
299 intval
= convert (type
, arg
);
300 intval
= gfc_evaluate_now (intval
, pblock
);
302 tmp
= convert (argtype
, intval
);
303 cond
= build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
305 tmp
= build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
306 build_int_cst (type
, 1));
307 tmp
= build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
312 /* Round to nearest integer, away from zero. */
315 build_round_expr (tree arg
, tree restype
)
320 int argprec
, resprec
;
322 argtype
= TREE_TYPE (arg
);
323 argprec
= TYPE_PRECISION (argtype
);
324 resprec
= TYPE_PRECISION (restype
);
326 /* Depending on the type of the result, choose the long int intrinsic
327 (lround family) or long long intrinsic (llround). We might also
328 need to convert the result afterwards. */
329 if (resprec
<= LONG_TYPE_SIZE
)
331 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
336 /* Now, depending on the argument type, we choose between intrinsics. */
337 if (argprec
== TYPE_PRECISION (float_type_node
))
338 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDF
: BUILT_IN_LROUNDF
];
339 else if (argprec
== TYPE_PRECISION (double_type_node
))
340 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUND
: BUILT_IN_LROUND
];
341 else if (argprec
== TYPE_PRECISION (long_double_type_node
))
342 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDL
: BUILT_IN_LROUNDL
];
346 return fold_convert (restype
, build_call_expr (fn
, 1, arg
));
350 /* Convert a real to an integer using a specific rounding mode.
351 Ideally we would just build the corresponding GENERIC node,
352 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
355 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
356 enum rounding_mode op
)
361 return build_fixbound_expr (pblock
, arg
, type
, 0);
365 return build_fixbound_expr (pblock
, arg
, type
, 1);
369 return build_round_expr (arg
, type
);
373 return build1 (FIX_TRUNC_EXPR
, type
, arg
);
382 /* Round a real value using the specified rounding mode.
383 We use a temporary integer of that same kind size as the result.
384 Values larger than those that can be represented by this kind are
385 unchanged, as they will not be accurate enough to represent the
387 huge = HUGE (KIND (a))
388 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
392 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
403 kind
= expr
->ts
.kind
;
404 nargs
= gfc_intrinsic_argument_list_length (expr
);
407 /* We have builtin functions for some cases. */
450 /* Evaluate the argument. */
451 gcc_assert (expr
->value
.function
.actual
->expr
);
452 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
454 /* Use a builtin function if one exists. */
455 if (n
!= END_BUILTINS
)
457 tmp
= built_in_decls
[n
];
458 se
->expr
= build_call_expr (tmp
, 1, arg
[0]);
462 /* This code is probably redundant, but we'll keep it lying around just
464 type
= gfc_typenode_for_spec (&expr
->ts
);
465 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
467 /* Test if the value is too large to handle sensibly. */
468 gfc_set_model_kind (kind
);
470 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
471 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
472 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
473 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
[0], tmp
);
475 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
476 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
477 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
[0], tmp
);
478 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
479 itype
= gfc_get_int_type (kind
);
481 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
482 tmp
= convert (type
, tmp
);
483 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
[0]);
488 /* Convert to an integer using the specified rounding mode. */
491 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
497 nargs
= gfc_intrinsic_argument_list_length (expr
);
498 args
= alloca (sizeof (tree
) * nargs
);
500 /* Evaluate the argument, we process all arguments even though we only
501 use the first one for code generation purposes. */
502 type
= gfc_typenode_for_spec (&expr
->ts
);
503 gcc_assert (expr
->value
.function
.actual
->expr
);
504 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
506 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
508 /* Conversion to a different integer kind. */
509 se
->expr
= convert (type
, args
[0]);
513 /* Conversion from complex to non-complex involves taking the real
514 component of the value. */
515 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
516 && expr
->ts
.type
!= BT_COMPLEX
)
520 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
521 args
[0] = build1 (REALPART_EXPR
, artype
, args
[0]);
524 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
529 /* Get the imaginary component of a value. */
532 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
536 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
537 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
541 /* Get the complex conjugate of a value. */
544 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
548 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
549 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
553 /* Initialize function decls for library functions. The external functions
554 are created as required. Builtin functions are added here. */
557 gfc_build_intrinsic_lib_fndecls (void)
559 gfc_intrinsic_map_t
*m
;
561 /* Add GCC builtin functions. */
562 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
564 if (m
->code_r4
!= END_BUILTINS
)
565 m
->real4_decl
= built_in_decls
[m
->code_r4
];
566 if (m
->code_r8
!= END_BUILTINS
)
567 m
->real8_decl
= built_in_decls
[m
->code_r8
];
568 if (m
->code_r10
!= END_BUILTINS
)
569 m
->real10_decl
= built_in_decls
[m
->code_r10
];
570 if (m
->code_r16
!= END_BUILTINS
)
571 m
->real16_decl
= built_in_decls
[m
->code_r16
];
572 if (m
->code_c4
!= END_BUILTINS
)
573 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
574 if (m
->code_c8
!= END_BUILTINS
)
575 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
576 if (m
->code_c10
!= END_BUILTINS
)
577 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
578 if (m
->code_c16
!= END_BUILTINS
)
579 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
584 /* Create a fndecl for a simple intrinsic library function. */
587 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
592 gfc_actual_arglist
*actual
;
595 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
598 if (ts
->type
== BT_REAL
)
603 pdecl
= &m
->real4_decl
;
606 pdecl
= &m
->real8_decl
;
609 pdecl
= &m
->real10_decl
;
612 pdecl
= &m
->real16_decl
;
618 else if (ts
->type
== BT_COMPLEX
)
620 gcc_assert (m
->complex_available
);
625 pdecl
= &m
->complex4_decl
;
628 pdecl
= &m
->complex8_decl
;
631 pdecl
= &m
->complex10_decl
;
634 pdecl
= &m
->complex16_decl
;
649 snprintf (name
, sizeof (name
), "%s%s%s",
650 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
651 else if (ts
->kind
== 8)
652 snprintf (name
, sizeof (name
), "%s%s",
653 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
656 gcc_assert (ts
->kind
== 10 || ts
->kind
== 16);
657 snprintf (name
, sizeof (name
), "%s%s%s",
658 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
663 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
664 ts
->type
== BT_COMPLEX
? 'c' : 'r',
668 argtypes
= NULL_TREE
;
669 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
671 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
672 argtypes
= gfc_chainon_list (argtypes
, type
);
674 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
675 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
676 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
678 /* Mark the decl as external. */
679 DECL_EXTERNAL (fndecl
) = 1;
680 TREE_PUBLIC (fndecl
) = 1;
682 /* Mark it __attribute__((const)), if possible. */
683 TREE_READONLY (fndecl
) = m
->is_constant
;
685 rest_of_decl_compilation (fndecl
, 1, 0);
692 /* Convert an intrinsic function into an external or builtin call. */
695 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
697 gfc_intrinsic_map_t
*m
;
701 unsigned int num_args
;
704 id
= expr
->value
.function
.isym
->id
;
705 /* Find the entry for this function. */
706 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
712 if (m
->id
== GFC_ISYM_NONE
)
714 internal_error ("Intrinsic function %s(%d) not recognized",
715 expr
->value
.function
.name
, id
);
718 /* Get the decl and generate the call. */
719 num_args
= gfc_intrinsic_argument_list_length (expr
);
720 args
= alloca (sizeof (tree
) * num_args
);
722 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
723 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
724 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
726 fndecl
= build_addr (fndecl
, current_function_decl
);
727 se
->expr
= build_call_array (rettype
, fndecl
, num_args
, args
);
730 /* Generate code for EXPONENT(X) intrinsic function. */
733 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
735 tree arg
, fndecl
, type
;
738 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
740 a1
= expr
->value
.function
.actual
->expr
;
744 fndecl
= gfor_fndecl_math_exponent4
;
747 fndecl
= gfor_fndecl_math_exponent8
;
750 fndecl
= gfor_fndecl_math_exponent10
;
753 fndecl
= gfor_fndecl_math_exponent16
;
759 /* Convert it to the required type. */
760 type
= gfc_typenode_for_spec (&expr
->ts
);
761 se
->expr
= fold_convert (type
, build_call_expr (fndecl
, 1, arg
));
764 /* Evaluate a single upper or lower bound. */
765 /* TODO: bound intrinsic generates way too much unnecessary code. */
768 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
770 gfc_actual_arglist
*arg
;
771 gfc_actual_arglist
*arg2
;
776 tree cond
, cond1
, cond2
, cond3
, cond4
, size
;
784 arg
= expr
->value
.function
.actual
;
789 /* Create an implicit second parameter from the loop variable. */
790 gcc_assert (!arg2
->expr
);
791 gcc_assert (se
->loop
->dimen
== 1);
792 gcc_assert (se
->ss
->expr
== expr
);
793 gfc_advance_se_ss_chain (se
);
794 bound
= se
->loop
->loopvar
[0];
795 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
800 /* use the passed argument. */
801 gcc_assert (arg
->next
->expr
);
802 gfc_init_se (&argse
, NULL
);
803 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
804 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
806 /* Convert from one based to zero based. */
807 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
811 /* TODO: don't re-evaluate the descriptor on each iteration. */
812 /* Get a descriptor for the first parameter. */
813 ss
= gfc_walk_expr (arg
->expr
);
814 gcc_assert (ss
!= gfc_ss_terminator
);
815 gfc_init_se (&argse
, NULL
);
816 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
817 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
818 gfc_add_block_to_block (&se
->post
, &argse
.post
);
822 if (INTEGER_CST_P (bound
))
826 hi
= TREE_INT_CST_HIGH (bound
);
827 low
= TREE_INT_CST_LOW (bound
);
828 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
829 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
830 "dimension index", upper
? "UBOUND" : "LBOUND",
835 if (flag_bounds_check
)
837 bound
= gfc_evaluate_now (bound
, &se
->pre
);
838 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
839 bound
, build_int_cst (TREE_TYPE (bound
), 0));
840 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
841 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
842 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
843 gfc_trans_runtime_check (cond
, &se
->pre
, &expr
->where
, gfc_msg_fault
);
847 ubound
= gfc_conv_descriptor_ubound (desc
, bound
);
848 lbound
= gfc_conv_descriptor_lbound (desc
, bound
);
850 /* Follow any component references. */
851 if (arg
->expr
->expr_type
== EXPR_VARIABLE
852 || arg
->expr
->expr_type
== EXPR_CONSTANT
)
854 as
= arg
->expr
->symtree
->n
.sym
->as
;
855 for (ref
= arg
->expr
->ref
; ref
; ref
= ref
->next
)
860 as
= ref
->u
.c
.component
->as
;
868 switch (ref
->u
.ar
.type
)
886 /* 13.14.53: Result value for LBOUND
888 Case (i): For an array section or for an array expression other than a
889 whole array or array structure component, LBOUND(ARRAY, DIM)
890 has the value 1. For a whole array or array structure
891 component, LBOUND(ARRAY, DIM) has the value:
892 (a) equal to the lower bound for subscript DIM of ARRAY if
893 dimension DIM of ARRAY does not have extent zero
894 or if ARRAY is an assumed-size array of rank DIM,
897 13.14.113: Result value for UBOUND
899 Case (i): For an array section or for an array expression other than a
900 whole array or array structure component, UBOUND(ARRAY, DIM)
901 has the value equal to the number of elements in the given
902 dimension; otherwise, it has a value equal to the upper bound
903 for subscript DIM of ARRAY if dimension DIM of ARRAY does
904 not have size zero and has value zero if dimension DIM has
909 tree stride
= gfc_conv_descriptor_stride (desc
, bound
);
911 cond1
= fold_build2 (GE_EXPR
, boolean_type_node
, ubound
, lbound
);
912 cond2
= fold_build2 (LE_EXPR
, boolean_type_node
, ubound
, lbound
);
914 cond3
= fold_build2 (GE_EXPR
, boolean_type_node
, stride
,
915 gfc_index_zero_node
);
916 cond3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond3
, cond1
);
918 cond4
= fold_build2 (LT_EXPR
, boolean_type_node
, stride
,
919 gfc_index_zero_node
);
920 cond4
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond4
, cond2
);
924 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
926 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
927 ubound
, gfc_index_zero_node
);
931 if (as
->type
== AS_ASSUMED_SIZE
)
932 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, bound
,
933 build_int_cst (TREE_TYPE (bound
),
934 arg
->expr
->rank
- 1));
936 cond
= boolean_false_node
;
938 cond1
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
939 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond1
);
941 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
942 lbound
, gfc_index_one_node
);
949 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
950 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
954 se
->expr
= gfc_index_one_node
;
957 type
= gfc_typenode_for_spec (&expr
->ts
);
958 se
->expr
= convert (type
, se
->expr
);
963 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
968 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
970 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
974 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (arg
), arg
);
978 switch (expr
->ts
.kind
)
993 se
->expr
= build_call_expr (built_in_decls
[n
], 1, arg
);
1002 /* Create a complex value from one or two real components. */
1005 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1011 unsigned int num_args
;
1013 num_args
= gfc_intrinsic_argument_list_length (expr
);
1014 args
= alloca (sizeof (tree
) * num_args
);
1016 type
= gfc_typenode_for_spec (&expr
->ts
);
1017 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1018 real
= convert (TREE_TYPE (type
), args
[0]);
1020 imag
= convert (TREE_TYPE (type
), args
[1]);
1021 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1023 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1024 imag
= convert (TREE_TYPE (type
), imag
);
1027 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1029 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
1032 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1033 MODULO(A, P) = A - FLOOR (A / P) * P */
1034 /* TODO: MOD(x, 0) */
1037 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1048 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1050 switch (expr
->ts
.type
)
1053 /* Integer case is easy, we've got a builtin op. */
1054 type
= TREE_TYPE (args
[0]);
1057 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, args
[0], args
[1]);
1059 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, args
[0], args
[1]);
1064 /* Check if we have a builtin fmod. */
1065 switch (expr
->ts
.kind
)
1084 /* Use it if it exists. */
1085 if (n
!= END_BUILTINS
)
1087 tmp
= build_addr (built_in_decls
[n
], current_function_decl
);
1088 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls
[n
])),
1094 type
= TREE_TYPE (args
[0]);
1096 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1097 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1100 modulo = arg - floor (arg/arg2) * arg2, so
1101 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1103 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1104 thereby avoiding another division and retaining the accuracy
1105 of the builtin function. */
1106 if (n
!= END_BUILTINS
&& modulo
)
1108 tree zero
= gfc_build_const (type
, integer_zero_node
);
1109 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1110 test
= build2 (LT_EXPR
, boolean_type_node
, args
[0], zero
);
1111 test2
= build2 (LT_EXPR
, boolean_type_node
, args
[1], zero
);
1112 test2
= build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
1113 test
= build2 (NE_EXPR
, boolean_type_node
, tmp
, zero
);
1114 test
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1115 test
= gfc_evaluate_now (test
, &se
->pre
);
1116 se
->expr
= build3 (COND_EXPR
, type
, test
,
1117 build2 (PLUS_EXPR
, type
, tmp
, args
[1]), tmp
);
1121 /* If we do not have a built_in fmod, the calculation is going to
1122 have to be done longhand. */
1123 tmp
= build2 (RDIV_EXPR
, type
, args
[0], args
[1]);
1125 /* Test if the value is too large to handle sensibly. */
1126 gfc_set_model_kind (expr
->ts
.kind
);
1128 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1129 ikind
= expr
->ts
.kind
;
1132 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1133 ikind
= gfc_max_integer_kind
;
1135 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1136 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1137 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
1139 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1140 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1141 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
1142 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1144 itype
= gfc_get_int_type (ikind
);
1146 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1148 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1149 tmp
= convert (type
, tmp
);
1150 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, args
[0]);
1151 tmp
= build2 (MULT_EXPR
, type
, tmp
, args
[1]);
1152 se
->expr
= build2 (MINUS_EXPR
, type
, args
[0], tmp
);
1161 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1164 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1172 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1173 type
= TREE_TYPE (args
[0]);
1175 val
= build2 (MINUS_EXPR
, type
, args
[0], args
[1]);
1176 val
= gfc_evaluate_now (val
, &se
->pre
);
1178 zero
= gfc_build_const (type
, integer_zero_node
);
1179 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
1180 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
1184 /* SIGN(A, B) is absolute value of A times sign of B.
1185 The real value versions use library functions to ensure the correct
1186 handling of negative zero. Integer case implemented as:
1187 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1191 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1197 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1198 if (expr
->ts
.type
== BT_REAL
)
1200 switch (expr
->ts
.kind
)
1203 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
1206 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
1210 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
1215 se
->expr
= build_call_expr (tmp
, 2, args
[0], args
[1]);
1219 /* Having excluded floating point types, we know we are now dealing
1220 with signed integer types. */
1221 type
= TREE_TYPE (args
[0]);
1223 /* Args[0] is used multiple times below. */
1224 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1226 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1227 the signs of A and B are the same, and of all ones if they differ. */
1228 tmp
= fold_build2 (BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1229 tmp
= fold_build2 (RSHIFT_EXPR
, type
, tmp
,
1230 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1231 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1233 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1234 is all ones (i.e. -1). */
1235 se
->expr
= fold_build2 (BIT_XOR_EXPR
, type
,
1236 fold_build2 (PLUS_EXPR
, type
, args
[0], tmp
),
1241 /* Test for the presence of an optional argument. */
1244 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1248 arg
= expr
->value
.function
.actual
->expr
;
1249 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1250 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1251 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1255 /* Calculate the double precision product of two single precision values. */
1258 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1263 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1265 /* Convert the args to double precision before multiplying. */
1266 type
= gfc_typenode_for_spec (&expr
->ts
);
1267 args
[0] = convert (type
, args
[0]);
1268 args
[1] = convert (type
, args
[1]);
1269 se
->expr
= build2 (MULT_EXPR
, type
, args
[0], args
[1]);
1273 /* Return a length one character string containing an ascii character. */
1276 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1282 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1284 /* We currently don't support character types != 1. */
1285 gcc_assert (expr
->ts
.kind
== 1);
1286 type
= gfc_character1_type_node
;
1287 var
= gfc_create_var (type
, "char");
1289 arg
= convert (type
, arg
);
1290 gfc_add_modify_expr (&se
->pre
, var
, arg
);
1291 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1292 se
->string_length
= integer_one_node
;
1297 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1304 tree gfc_int8_type_node
= gfc_get_int_type (8);
1307 unsigned int num_args
;
1309 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1310 args
= alloca (sizeof (tree
) * num_args
);
1312 type
= build_pointer_type (gfc_character1_type_node
);
1313 var
= gfc_create_var (type
, "pstr");
1314 len
= gfc_create_var (gfc_int8_type_node
, "len");
1316 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1317 args
[0] = build_fold_addr_expr (var
);
1318 args
[1] = build_fold_addr_expr (len
);
1320 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
1321 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1322 fndecl
, num_args
, args
);
1323 gfc_add_expr_to_block (&se
->pre
, tmp
);
1325 /* Free the temporary afterwards, if necessary. */
1326 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1327 build_int_cst (TREE_TYPE (len
), 0));
1328 tmp
= gfc_call_free (var
);
1329 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1330 gfc_add_expr_to_block (&se
->post
, tmp
);
1333 se
->string_length
= len
;
1338 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1345 tree gfc_int4_type_node
= gfc_get_int_type (4);
1348 unsigned int num_args
;
1350 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1351 args
= alloca (sizeof (tree
) * num_args
);
1353 type
= build_pointer_type (gfc_character1_type_node
);
1354 var
= gfc_create_var (type
, "pstr");
1355 len
= gfc_create_var (gfc_int4_type_node
, "len");
1357 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1358 args
[0] = build_fold_addr_expr (var
);
1359 args
[1] = build_fold_addr_expr (len
);
1361 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1362 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1363 fndecl
, num_args
, args
);
1364 gfc_add_expr_to_block (&se
->pre
, tmp
);
1366 /* Free the temporary afterwards, if necessary. */
1367 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1368 build_int_cst (TREE_TYPE (len
), 0));
1369 tmp
= gfc_call_free (var
);
1370 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1371 gfc_add_expr_to_block (&se
->post
, tmp
);
1374 se
->string_length
= len
;
1378 /* Return a character string containing the tty name. */
1381 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1389 tree gfc_int4_type_node
= gfc_get_int_type (4);
1391 unsigned int num_args
;
1393 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1394 args
= alloca (sizeof (tree
) * num_args
);
1396 type
= build_pointer_type (gfc_character1_type_node
);
1397 var
= gfc_create_var (type
, "pstr");
1398 len
= gfc_create_var (gfc_int4_type_node
, "len");
1400 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1401 args
[0] = build_fold_addr_expr (var
);
1402 args
[1] = build_fold_addr_expr (len
);
1404 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1405 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1406 fndecl
, num_args
, args
);
1407 gfc_add_expr_to_block (&se
->pre
, tmp
);
1409 /* Free the temporary afterwards, if necessary. */
1410 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1411 build_int_cst (TREE_TYPE (len
), 0));
1412 tmp
= gfc_call_free (var
);
1413 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1414 gfc_add_expr_to_block (&se
->post
, tmp
);
1417 se
->string_length
= len
;
1421 /* Get the minimum/maximum value of all the parameters.
1422 minmax (a1, a2, a3, ...)
1425 if (a2 .op. mvar || isnan(mvar))
1427 if (a3 .op. mvar || isnan(mvar))
1434 /* TODO: Mismatching types can occur when specific names are used.
1435 These should be handled during resolution. */
1437 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1445 gfc_actual_arglist
*argexpr
;
1446 unsigned int i
, nargs
;
1448 nargs
= gfc_intrinsic_argument_list_length (expr
);
1449 args
= alloca (sizeof (tree
) * nargs
);
1451 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1452 type
= gfc_typenode_for_spec (&expr
->ts
);
1454 argexpr
= expr
->value
.function
.actual
;
1455 if (TREE_TYPE (args
[0]) != type
)
1456 args
[0] = convert (type
, args
[0]);
1457 /* Only evaluate the argument once. */
1458 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
1459 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1461 mvar
= gfc_create_var (type
, "M");
1462 gfc_add_modify_expr (&se
->pre
, mvar
, args
[0]);
1463 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1469 /* Handle absent optional arguments by ignoring the comparison. */
1470 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1471 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1472 && TREE_CODE (val
) == INDIRECT_REF
)
1473 cond
= build2 (NE_EXPR
, boolean_type_node
, TREE_OPERAND (val
, 0),
1474 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1479 /* Only evaluate the argument once. */
1480 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1481 val
= gfc_evaluate_now (val
, &se
->pre
);
1484 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1486 tmp
= build2 (op
, boolean_type_node
, convert (type
, val
), mvar
);
1488 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1489 __builtin_isnan might be made dependent on that module being loaded,
1490 to help performance of programs that don't rely on IEEE semantics. */
1491 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
1493 isnan
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, mvar
);
1494 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
,
1495 fold_convert (boolean_type_node
, isnan
));
1497 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, build_empty_stmt ());
1499 if (cond
!= NULL_TREE
)
1500 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1502 gfc_add_expr_to_block (&se
->pre
, tmp
);
1503 argexpr
= argexpr
->next
;
1509 /* Generate library calls for MIN and MAX intrinsics for character
1512 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
1515 tree var
, len
, fndecl
, tmp
, cond
;
1518 nargs
= gfc_intrinsic_argument_list_length (expr
);
1519 args
= alloca (sizeof (tree
) * (nargs
+ 4));
1520 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
1522 /* Create the result variables. */
1523 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1524 args
[0] = build_fold_addr_expr (len
);
1525 var
= gfc_create_var (build_pointer_type (gfc_character1_type_node
), "pstr");
1526 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
1527 args
[2] = build_int_cst (NULL_TREE
, op
);
1528 args
[3] = build_int_cst (NULL_TREE
, nargs
/ 2);
1530 /* Make the function call. */
1531 fndecl
= build_addr (gfor_fndecl_string_minmax
, current_function_decl
);
1532 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax
)),
1533 fndecl
, nargs
+ 4, args
);
1534 gfc_add_expr_to_block (&se
->pre
, tmp
);
1536 /* Free the temporary afterwards, if necessary. */
1537 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1538 build_int_cst (TREE_TYPE (len
), 0));
1539 tmp
= gfc_call_free (var
);
1540 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1541 gfc_add_expr_to_block (&se
->post
, tmp
);
1544 se
->string_length
= len
;
1548 /* Create a symbol node for this intrinsic. The symbol from the frontend
1549 has the generic name. */
1552 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1556 /* TODO: Add symbols for intrinsic function to the global namespace. */
1557 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1558 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1561 sym
->attr
.external
= 1;
1562 sym
->attr
.function
= 1;
1563 sym
->attr
.always_explicit
= 1;
1564 sym
->attr
.proc
= PROC_INTRINSIC
;
1565 sym
->attr
.flavor
= FL_PROCEDURE
;
1569 sym
->attr
.dimension
= 1;
1570 sym
->as
= gfc_get_array_spec ();
1571 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1572 sym
->as
->rank
= expr
->rank
;
1575 /* TODO: proper argument lists for external intrinsics. */
1579 /* Generate a call to an external intrinsic function. */
1581 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1586 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1589 gcc_assert (expr
->rank
> 0);
1591 gcc_assert (expr
->rank
== 0);
1593 sym
= gfc_get_symbol_for_expr (expr
);
1595 /* Calls to libgfortran_matmul need to be appended special arguments,
1596 to be able to call the BLAS ?gemm functions if required and possible. */
1597 append_args
= NULL_TREE
;
1598 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1599 && sym
->ts
.type
!= BT_LOGICAL
)
1601 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1603 if (gfc_option
.flag_external_blas
1604 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1605 && (sym
->ts
.kind
== gfc_default_real_kind
1606 || sym
->ts
.kind
== gfc_default_double_kind
))
1610 if (sym
->ts
.type
== BT_REAL
)
1612 if (sym
->ts
.kind
== gfc_default_real_kind
)
1613 gemm_fndecl
= gfor_fndecl_sgemm
;
1615 gemm_fndecl
= gfor_fndecl_dgemm
;
1619 if (sym
->ts
.kind
== gfc_default_real_kind
)
1620 gemm_fndecl
= gfor_fndecl_cgemm
;
1622 gemm_fndecl
= gfor_fndecl_zgemm
;
1625 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 1));
1626 append_args
= gfc_chainon_list
1627 (append_args
, build_int_cst
1628 (cint
, gfc_option
.blas_matmul_limit
));
1629 append_args
= gfc_chainon_list (append_args
,
1630 gfc_build_addr_expr (NULL_TREE
,
1635 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 0));
1636 append_args
= gfc_chainon_list (append_args
, build_int_cst (cint
, 0));
1637 append_args
= gfc_chainon_list (append_args
, null_pointer_node
);
1641 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
1645 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1665 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1674 gfc_actual_arglist
*actual
;
1681 gfc_conv_intrinsic_funcall (se
, expr
);
1685 actual
= expr
->value
.function
.actual
;
1686 type
= gfc_typenode_for_spec (&expr
->ts
);
1687 /* Initialize the result. */
1688 resvar
= gfc_create_var (type
, "test");
1690 tmp
= convert (type
, boolean_true_node
);
1692 tmp
= convert (type
, boolean_false_node
);
1693 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1695 /* Walk the arguments. */
1696 arrayss
= gfc_walk_expr (actual
->expr
);
1697 gcc_assert (arrayss
!= gfc_ss_terminator
);
1699 /* Initialize the scalarizer. */
1700 gfc_init_loopinfo (&loop
);
1701 exit_label
= gfc_build_label_decl (NULL_TREE
);
1702 TREE_USED (exit_label
) = 1;
1703 gfc_add_ss_to_loop (&loop
, arrayss
);
1705 /* Initialize the loop. */
1706 gfc_conv_ss_startstride (&loop
);
1707 gfc_conv_loop_setup (&loop
);
1709 gfc_mark_ss_chain_used (arrayss
, 1);
1710 /* Generate the loop body. */
1711 gfc_start_scalarized_body (&loop
, &body
);
1713 /* If the condition matches then set the return value. */
1714 gfc_start_block (&block
);
1716 tmp
= convert (type
, boolean_false_node
);
1718 tmp
= convert (type
, boolean_true_node
);
1719 gfc_add_modify_expr (&block
, resvar
, tmp
);
1721 /* And break out of the loop. */
1722 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1723 gfc_add_expr_to_block (&block
, tmp
);
1725 found
= gfc_finish_block (&block
);
1727 /* Check this element. */
1728 gfc_init_se (&arrayse
, NULL
);
1729 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1730 arrayse
.ss
= arrayss
;
1731 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1733 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1734 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1735 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1736 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1737 gfc_add_expr_to_block (&body
, tmp
);
1738 gfc_add_block_to_block (&body
, &arrayse
.post
);
1740 gfc_trans_scalarizing_loops (&loop
, &body
);
1742 /* Add the exit label. */
1743 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1744 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1746 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1747 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1748 gfc_cleanup_loop (&loop
);
1753 /* COUNT(A) = Number of true elements in A. */
1755 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1762 gfc_actual_arglist
*actual
;
1768 gfc_conv_intrinsic_funcall (se
, expr
);
1772 actual
= expr
->value
.function
.actual
;
1774 type
= gfc_typenode_for_spec (&expr
->ts
);
1775 /* Initialize the result. */
1776 resvar
= gfc_create_var (type
, "count");
1777 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1779 /* Walk the arguments. */
1780 arrayss
= gfc_walk_expr (actual
->expr
);
1781 gcc_assert (arrayss
!= gfc_ss_terminator
);
1783 /* Initialize the scalarizer. */
1784 gfc_init_loopinfo (&loop
);
1785 gfc_add_ss_to_loop (&loop
, arrayss
);
1787 /* Initialize the loop. */
1788 gfc_conv_ss_startstride (&loop
);
1789 gfc_conv_loop_setup (&loop
);
1791 gfc_mark_ss_chain_used (arrayss
, 1);
1792 /* Generate the loop body. */
1793 gfc_start_scalarized_body (&loop
, &body
);
1795 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1796 build_int_cst (TREE_TYPE (resvar
), 1));
1797 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1799 gfc_init_se (&arrayse
, NULL
);
1800 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1801 arrayse
.ss
= arrayss
;
1802 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1803 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1805 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1806 gfc_add_expr_to_block (&body
, tmp
);
1807 gfc_add_block_to_block (&body
, &arrayse
.post
);
1809 gfc_trans_scalarizing_loops (&loop
, &body
);
1811 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1812 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1813 gfc_cleanup_loop (&loop
);
1818 /* Inline implementation of the sum and product intrinsics. */
1820 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1828 gfc_actual_arglist
*actual
;
1833 gfc_expr
*arrayexpr
;
1838 gfc_conv_intrinsic_funcall (se
, expr
);
1842 type
= gfc_typenode_for_spec (&expr
->ts
);
1843 /* Initialize the result. */
1844 resvar
= gfc_create_var (type
, "val");
1845 if (op
== PLUS_EXPR
)
1846 tmp
= gfc_build_const (type
, integer_zero_node
);
1848 tmp
= gfc_build_const (type
, integer_one_node
);
1850 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1852 /* Walk the arguments. */
1853 actual
= expr
->value
.function
.actual
;
1854 arrayexpr
= actual
->expr
;
1855 arrayss
= gfc_walk_expr (arrayexpr
);
1856 gcc_assert (arrayss
!= gfc_ss_terminator
);
1858 actual
= actual
->next
->next
;
1859 gcc_assert (actual
);
1860 maskexpr
= actual
->expr
;
1861 if (maskexpr
&& maskexpr
->rank
!= 0)
1863 maskss
= gfc_walk_expr (maskexpr
);
1864 gcc_assert (maskss
!= gfc_ss_terminator
);
1869 /* Initialize the scalarizer. */
1870 gfc_init_loopinfo (&loop
);
1871 gfc_add_ss_to_loop (&loop
, arrayss
);
1873 gfc_add_ss_to_loop (&loop
, maskss
);
1875 /* Initialize the loop. */
1876 gfc_conv_ss_startstride (&loop
);
1877 gfc_conv_loop_setup (&loop
);
1879 gfc_mark_ss_chain_used (arrayss
, 1);
1881 gfc_mark_ss_chain_used (maskss
, 1);
1882 /* Generate the loop body. */
1883 gfc_start_scalarized_body (&loop
, &body
);
1885 /* If we have a mask, only add this element if the mask is set. */
1888 gfc_init_se (&maskse
, NULL
);
1889 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1891 gfc_conv_expr_val (&maskse
, maskexpr
);
1892 gfc_add_block_to_block (&body
, &maskse
.pre
);
1894 gfc_start_block (&block
);
1897 gfc_init_block (&block
);
1899 /* Do the actual summation/product. */
1900 gfc_init_se (&arrayse
, NULL
);
1901 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1902 arrayse
.ss
= arrayss
;
1903 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1904 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1906 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1907 gfc_add_modify_expr (&block
, resvar
, tmp
);
1908 gfc_add_block_to_block (&block
, &arrayse
.post
);
1912 /* We enclose the above in if (mask) {...} . */
1913 tmp
= gfc_finish_block (&block
);
1915 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1918 tmp
= gfc_finish_block (&block
);
1919 gfc_add_expr_to_block (&body
, tmp
);
1921 gfc_trans_scalarizing_loops (&loop
, &body
);
1923 /* For a scalar mask, enclose the loop in an if statement. */
1924 if (maskexpr
&& maskss
== NULL
)
1926 gfc_init_se (&maskse
, NULL
);
1927 gfc_conv_expr_val (&maskse
, maskexpr
);
1928 gfc_init_block (&block
);
1929 gfc_add_block_to_block (&block
, &loop
.pre
);
1930 gfc_add_block_to_block (&block
, &loop
.post
);
1931 tmp
= gfc_finish_block (&block
);
1933 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1934 gfc_add_expr_to_block (&block
, tmp
);
1935 gfc_add_block_to_block (&se
->pre
, &block
);
1939 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1940 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1943 gfc_cleanup_loop (&loop
);
1949 /* Inline implementation of the dot_product intrinsic. This function
1950 is based on gfc_conv_intrinsic_arith (the previous function). */
1952 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1960 gfc_actual_arglist
*actual
;
1961 gfc_ss
*arrayss1
, *arrayss2
;
1962 gfc_se arrayse1
, arrayse2
;
1963 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1965 type
= gfc_typenode_for_spec (&expr
->ts
);
1967 /* Initialize the result. */
1968 resvar
= gfc_create_var (type
, "val");
1969 if (expr
->ts
.type
== BT_LOGICAL
)
1970 tmp
= build_int_cst (type
, 0);
1972 tmp
= gfc_build_const (type
, integer_zero_node
);
1974 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1976 /* Walk argument #1. */
1977 actual
= expr
->value
.function
.actual
;
1978 arrayexpr1
= actual
->expr
;
1979 arrayss1
= gfc_walk_expr (arrayexpr1
);
1980 gcc_assert (arrayss1
!= gfc_ss_terminator
);
1982 /* Walk argument #2. */
1983 actual
= actual
->next
;
1984 arrayexpr2
= actual
->expr
;
1985 arrayss2
= gfc_walk_expr (arrayexpr2
);
1986 gcc_assert (arrayss2
!= gfc_ss_terminator
);
1988 /* Initialize the scalarizer. */
1989 gfc_init_loopinfo (&loop
);
1990 gfc_add_ss_to_loop (&loop
, arrayss1
);
1991 gfc_add_ss_to_loop (&loop
, arrayss2
);
1993 /* Initialize the loop. */
1994 gfc_conv_ss_startstride (&loop
);
1995 gfc_conv_loop_setup (&loop
);
1997 gfc_mark_ss_chain_used (arrayss1
, 1);
1998 gfc_mark_ss_chain_used (arrayss2
, 1);
2000 /* Generate the loop body. */
2001 gfc_start_scalarized_body (&loop
, &body
);
2002 gfc_init_block (&block
);
2004 /* Make the tree expression for [conjg(]array1[)]. */
2005 gfc_init_se (&arrayse1
, NULL
);
2006 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2007 arrayse1
.ss
= arrayss1
;
2008 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2009 if (expr
->ts
.type
== BT_COMPLEX
)
2010 arrayse1
.expr
= build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
2011 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2013 /* Make the tree expression for array2. */
2014 gfc_init_se (&arrayse2
, NULL
);
2015 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2016 arrayse2
.ss
= arrayss2
;
2017 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2018 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2020 /* Do the actual product and sum. */
2021 if (expr
->ts
.type
== BT_LOGICAL
)
2023 tmp
= build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2024 tmp
= build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2028 tmp
= build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2029 tmp
= build2 (PLUS_EXPR
, type
, resvar
, tmp
);
2031 gfc_add_modify_expr (&block
, resvar
, tmp
);
2033 /* Finish up the loop block and the loop. */
2034 tmp
= gfc_finish_block (&block
);
2035 gfc_add_expr_to_block (&body
, tmp
);
2037 gfc_trans_scalarizing_loops (&loop
, &body
);
2038 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2039 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2040 gfc_cleanup_loop (&loop
);
2047 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
2051 stmtblock_t ifblock
;
2052 stmtblock_t elseblock
;
2060 gfc_actual_arglist
*actual
;
2065 gfc_expr
*arrayexpr
;
2072 gfc_conv_intrinsic_funcall (se
, expr
);
2076 /* Initialize the result. */
2077 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2078 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2079 type
= gfc_typenode_for_spec (&expr
->ts
);
2081 /* Walk the arguments. */
2082 actual
= expr
->value
.function
.actual
;
2083 arrayexpr
= actual
->expr
;
2084 arrayss
= gfc_walk_expr (arrayexpr
);
2085 gcc_assert (arrayss
!= gfc_ss_terminator
);
2087 actual
= actual
->next
->next
;
2088 gcc_assert (actual
);
2089 maskexpr
= actual
->expr
;
2090 if (maskexpr
&& maskexpr
->rank
!= 0)
2092 maskss
= gfc_walk_expr (maskexpr
);
2093 gcc_assert (maskss
!= gfc_ss_terminator
);
2098 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2099 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2100 switch (arrayexpr
->ts
.type
)
2103 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
2107 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2108 arrayexpr
->ts
.kind
);
2115 /* We start with the most negative possible value for MAXLOC, and the most
2116 positive possible value for MINLOC. The most negative possible value is
2117 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2118 possible value is HUGE in both cases. */
2120 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2121 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
2123 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2124 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2125 build_int_cst (type
, 1));
2127 /* Initialize the scalarizer. */
2128 gfc_init_loopinfo (&loop
);
2129 gfc_add_ss_to_loop (&loop
, arrayss
);
2131 gfc_add_ss_to_loop (&loop
, maskss
);
2133 /* Initialize the loop. */
2134 gfc_conv_ss_startstride (&loop
);
2135 gfc_conv_loop_setup (&loop
);
2137 gcc_assert (loop
.dimen
== 1);
2139 /* Initialize the position to zero, following Fortran 2003. We are free
2140 to do this because Fortran 95 allows the result of an entirely false
2141 mask to be processor dependent. */
2142 gfc_add_modify_expr (&loop
.pre
, pos
, gfc_index_zero_node
);
2144 gfc_mark_ss_chain_used (arrayss
, 1);
2146 gfc_mark_ss_chain_used (maskss
, 1);
2147 /* Generate the loop body. */
2148 gfc_start_scalarized_body (&loop
, &body
);
2150 /* If we have a mask, only check this element if the mask is set. */
2153 gfc_init_se (&maskse
, NULL
);
2154 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2156 gfc_conv_expr_val (&maskse
, maskexpr
);
2157 gfc_add_block_to_block (&body
, &maskse
.pre
);
2159 gfc_start_block (&block
);
2162 gfc_init_block (&block
);
2164 /* Compare with the current limit. */
2165 gfc_init_se (&arrayse
, NULL
);
2166 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2167 arrayse
.ss
= arrayss
;
2168 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2169 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2171 /* We do the following if this is a more extreme value. */
2172 gfc_start_block (&ifblock
);
2174 /* Assign the value to the limit... */
2175 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
2177 /* Remember where we are. An offset must be added to the loop
2178 counter to obtain the required position. */
2180 tmp
= build_int_cst (gfc_array_index_type
, 1);
2182 tmp
=fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2183 gfc_index_one_node
, loop
.from
[0]);
2184 gfc_add_modify_expr (&block
, offset
, tmp
);
2186 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2187 loop
.loopvar
[0], offset
);
2188 gfc_add_modify_expr (&ifblock
, pos
, tmp
);
2190 ifbody
= gfc_finish_block (&ifblock
);
2192 /* If it is a more extreme value or pos is still zero and the value
2193 equal to the limit. */
2194 tmp
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2195 build2 (EQ_EXPR
, boolean_type_node
, pos
, gfc_index_zero_node
),
2196 build2 (EQ_EXPR
, boolean_type_node
, arrayse
.expr
, limit
));
2197 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2198 build2 (op
, boolean_type_node
, arrayse
.expr
, limit
), tmp
);
2199 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2200 gfc_add_expr_to_block (&block
, tmp
);
2204 /* We enclose the above in if (mask) {...}. */
2205 tmp
= gfc_finish_block (&block
);
2207 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2210 tmp
= gfc_finish_block (&block
);
2211 gfc_add_expr_to_block (&body
, tmp
);
2213 gfc_trans_scalarizing_loops (&loop
, &body
);
2215 /* For a scalar mask, enclose the loop in an if statement. */
2216 if (maskexpr
&& maskss
== NULL
)
2218 gfc_init_se (&maskse
, NULL
);
2219 gfc_conv_expr_val (&maskse
, maskexpr
);
2220 gfc_init_block (&block
);
2221 gfc_add_block_to_block (&block
, &loop
.pre
);
2222 gfc_add_block_to_block (&block
, &loop
.post
);
2223 tmp
= gfc_finish_block (&block
);
2225 /* For the else part of the scalar mask, just initialize
2226 the pos variable the same way as above. */
2228 gfc_init_block (&elseblock
);
2229 gfc_add_modify_expr (&elseblock
, pos
, gfc_index_zero_node
);
2230 elsetmp
= gfc_finish_block (&elseblock
);
2232 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2233 gfc_add_expr_to_block (&block
, tmp
);
2234 gfc_add_block_to_block (&se
->pre
, &block
);
2238 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2239 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2241 gfc_cleanup_loop (&loop
);
2243 se
->expr
= convert (type
, pos
);
2247 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
2256 gfc_actual_arglist
*actual
;
2261 gfc_expr
*arrayexpr
;
2267 gfc_conv_intrinsic_funcall (se
, expr
);
2271 type
= gfc_typenode_for_spec (&expr
->ts
);
2272 /* Initialize the result. */
2273 limit
= gfc_create_var (type
, "limit");
2274 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2275 switch (expr
->ts
.type
)
2278 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
2282 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2289 /* We start with the most negative possible value for MAXVAL, and the most
2290 positive possible value for MINVAL. The most negative possible value is
2291 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2292 possible value is HUGE in both cases. */
2294 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2296 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2297 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2298 build_int_cst (type
, 1));
2300 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
2302 /* Walk the arguments. */
2303 actual
= expr
->value
.function
.actual
;
2304 arrayexpr
= actual
->expr
;
2305 arrayss
= gfc_walk_expr (arrayexpr
);
2306 gcc_assert (arrayss
!= gfc_ss_terminator
);
2308 actual
= actual
->next
->next
;
2309 gcc_assert (actual
);
2310 maskexpr
= actual
->expr
;
2311 if (maskexpr
&& maskexpr
->rank
!= 0)
2313 maskss
= gfc_walk_expr (maskexpr
);
2314 gcc_assert (maskss
!= gfc_ss_terminator
);
2319 /* Initialize the scalarizer. */
2320 gfc_init_loopinfo (&loop
);
2321 gfc_add_ss_to_loop (&loop
, arrayss
);
2323 gfc_add_ss_to_loop (&loop
, maskss
);
2325 /* Initialize the loop. */
2326 gfc_conv_ss_startstride (&loop
);
2327 gfc_conv_loop_setup (&loop
);
2329 gfc_mark_ss_chain_used (arrayss
, 1);
2331 gfc_mark_ss_chain_used (maskss
, 1);
2332 /* Generate the loop body. */
2333 gfc_start_scalarized_body (&loop
, &body
);
2335 /* If we have a mask, only add this element if the mask is set. */
2338 gfc_init_se (&maskse
, NULL
);
2339 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2341 gfc_conv_expr_val (&maskse
, maskexpr
);
2342 gfc_add_block_to_block (&body
, &maskse
.pre
);
2344 gfc_start_block (&block
);
2347 gfc_init_block (&block
);
2349 /* Compare with the current limit. */
2350 gfc_init_se (&arrayse
, NULL
);
2351 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2352 arrayse
.ss
= arrayss
;
2353 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2354 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2356 /* Assign the value to the limit... */
2357 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2359 /* If it is a more extreme value. */
2360 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2361 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2362 gfc_add_expr_to_block (&block
, tmp
);
2363 gfc_add_block_to_block (&block
, &arrayse
.post
);
2365 tmp
= gfc_finish_block (&block
);
2367 /* We enclose the above in if (mask) {...}. */
2368 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2369 gfc_add_expr_to_block (&body
, tmp
);
2371 gfc_trans_scalarizing_loops (&loop
, &body
);
2373 /* For a scalar mask, enclose the loop in an if statement. */
2374 if (maskexpr
&& maskss
== NULL
)
2376 gfc_init_se (&maskse
, NULL
);
2377 gfc_conv_expr_val (&maskse
, maskexpr
);
2378 gfc_init_block (&block
);
2379 gfc_add_block_to_block (&block
, &loop
.pre
);
2380 gfc_add_block_to_block (&block
, &loop
.post
);
2381 tmp
= gfc_finish_block (&block
);
2383 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2384 gfc_add_expr_to_block (&block
, tmp
);
2385 gfc_add_block_to_block (&se
->pre
, &block
);
2389 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2390 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2393 gfc_cleanup_loop (&loop
);
2398 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2400 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2406 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2407 type
= TREE_TYPE (args
[0]);
2409 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2410 tmp
= build2 (BIT_AND_EXPR
, type
, args
[0], tmp
);
2411 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2412 build_int_cst (type
, 0));
2413 type
= gfc_typenode_for_spec (&expr
->ts
);
2414 se
->expr
= convert (type
, tmp
);
2417 /* Generate code to perform the specified operation. */
2419 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
2423 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2424 se
->expr
= fold_build2 (op
, TREE_TYPE (args
[0]), args
[0], args
[1]);
2429 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2433 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2434 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2437 /* Set or clear a single bit. */
2439 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2446 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2447 type
= TREE_TYPE (args
[0]);
2449 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2455 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2457 se
->expr
= fold_build2 (op
, type
, args
[0], tmp
);
2460 /* Extract a sequence of bits.
2461 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2463 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2470 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2471 type
= TREE_TYPE (args
[0]);
2473 mask
= build_int_cst (type
, -1);
2474 mask
= build2 (LSHIFT_EXPR
, type
, mask
, args
[2]);
2475 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
2477 tmp
= build2 (RSHIFT_EXPR
, type
, args
[0], args
[1]);
2479 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2482 /* RSHIFT (I, SHIFT) = I >> SHIFT
2483 LSHIFT (I, SHIFT) = I << SHIFT */
2485 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
2489 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2491 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
2492 TREE_TYPE (args
[0]), args
[0], args
[1]);
2495 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2497 : ((shift >= 0) ? i << shift : i >> -shift)
2498 where all shifts are logical shifts. */
2500 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2512 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2513 type
= TREE_TYPE (args
[0]);
2514 utype
= unsigned_type_for (type
);
2516 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2518 /* Left shift if positive. */
2519 lshift
= fold_build2 (LSHIFT_EXPR
, type
, args
[0], width
);
2521 /* Right shift if negative.
2522 We convert to an unsigned type because we want a logical shift.
2523 The standard doesn't define the case of shifting negative
2524 numbers, and we try to be compatible with other compilers, most
2525 notably g77, here. */
2526 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
2527 convert (utype
, args
[0]), width
));
2529 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, args
[1],
2530 build_int_cst (TREE_TYPE (args
[1]), 0));
2531 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2533 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2534 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2536 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
2537 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2539 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2540 build_int_cst (type
, 0), tmp
);
2544 /* Circular shift. AKA rotate or barrel shift. */
2547 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2555 unsigned int num_args
;
2557 num_args
= gfc_intrinsic_argument_list_length (expr
);
2558 args
= alloca (sizeof (tree
) * num_args
);
2560 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2564 /* Use a library function for the 3 parameter version. */
2565 tree int4type
= gfc_get_int_type (4);
2567 type
= TREE_TYPE (args
[0]);
2568 /* We convert the first argument to at least 4 bytes, and
2569 convert back afterwards. This removes the need for library
2570 functions for all argument sizes, and function will be
2571 aligned to at least 32 bits, so there's no loss. */
2572 if (expr
->ts
.kind
< 4)
2573 args
[0] = convert (int4type
, args
[0]);
2575 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2576 need loads of library functions. They cannot have values >
2577 BIT_SIZE (I) so the conversion is safe. */
2578 args
[1] = convert (int4type
, args
[1]);
2579 args
[2] = convert (int4type
, args
[2]);
2581 switch (expr
->ts
.kind
)
2586 tmp
= gfor_fndecl_math_ishftc4
;
2589 tmp
= gfor_fndecl_math_ishftc8
;
2592 tmp
= gfor_fndecl_math_ishftc16
;
2597 se
->expr
= build_call_expr (tmp
, 3, args
[0], args
[1], args
[2]);
2598 /* Convert the result back to the original type, if we extended
2599 the first argument's width above. */
2600 if (expr
->ts
.kind
< 4)
2601 se
->expr
= convert (type
, se
->expr
);
2605 type
= TREE_TYPE (args
[0]);
2607 /* Rotate left if positive. */
2608 lrot
= fold_build2 (LROTATE_EXPR
, type
, args
[0], args
[1]);
2610 /* Rotate right if negative. */
2611 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2612 rrot
= fold_build2 (RROTATE_EXPR
, type
, args
[0], tmp
);
2614 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
2615 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, args
[1], zero
);
2616 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2618 /* Do nothing if shift == 0. */
2619 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
2620 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, args
[0], rrot
);
2623 /* The length of a character string. */
2625 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2635 gcc_assert (!se
->ss
);
2637 arg
= expr
->value
.function
.actual
->expr
;
2639 type
= gfc_typenode_for_spec (&expr
->ts
);
2640 switch (arg
->expr_type
)
2643 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2647 /* Obtain the string length from the function used by
2648 trans-array.c(gfc_trans_array_constructor). */
2650 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
2654 if (arg
->ref
== NULL
2655 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
2657 /* This doesn't catch all cases.
2658 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2659 and the surrounding thread. */
2660 sym
= arg
->symtree
->n
.sym
;
2661 decl
= gfc_get_symbol_decl (sym
);
2662 if (decl
== current_function_decl
&& sym
->attr
.function
2663 && (sym
->result
== sym
))
2664 decl
= gfc_get_fake_result_decl (sym
, 0);
2666 len
= sym
->ts
.cl
->backend_decl
;
2671 /* Otherwise fall through. */
2674 /* Anybody stupid enough to do this deserves inefficient code. */
2675 ss
= gfc_walk_expr (arg
);
2676 gfc_init_se (&argse
, se
);
2677 if (ss
== gfc_ss_terminator
)
2678 gfc_conv_expr (&argse
, arg
);
2680 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2681 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2682 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2683 len
= argse
.string_length
;
2686 se
->expr
= convert (type
, len
);
2689 /* The length of a character string not including trailing blanks. */
2691 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2696 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2697 type
= gfc_typenode_for_spec (&expr
->ts
);
2698 se
->expr
= build_call_expr (gfor_fndecl_string_len_trim
, 2, args
[0], args
[1]);
2699 se
->expr
= convert (type
, se
->expr
);
2703 /* Returns the starting position of a substring within a string. */
2706 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
2709 tree logical4_type_node
= gfc_get_logical_type (4);
2713 unsigned int num_args
;
2715 num_args
= gfc_intrinsic_argument_list_length (expr
);
2716 args
= alloca (sizeof (tree
) * 5);
2718 gfc_conv_intrinsic_function_args (se
, expr
, args
,
2719 num_args
>= 5 ? 5 : num_args
);
2720 type
= gfc_typenode_for_spec (&expr
->ts
);
2723 args
[4] = build_int_cst (logical4_type_node
, 0);
2725 args
[4] = convert (logical4_type_node
, args
[4]);
2727 fndecl
= build_addr (function
, current_function_decl
);
2728 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2730 se
->expr
= convert (type
, se
->expr
);
2734 /* The ascii value for a single character. */
2736 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2741 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2742 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
2743 args
[1] = build1 (NOP_EXPR
, pchar_type_node
, args
[1]);
2744 type
= gfc_typenode_for_spec (&expr
->ts
);
2746 se
->expr
= build_fold_indirect_ref (args
[1]);
2747 se
->expr
= convert (type
, se
->expr
);
2751 /* Intrinsic ISNAN calls __builtin_isnan. */
2754 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
2758 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2759 se
->expr
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
2760 STRIP_TYPE_NOPS (se
->expr
);
2761 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2765 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
2766 their argument against a constant integer value. */
2769 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
2773 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2774 se
->expr
= fold_build2 (EQ_EXPR
, gfc_typenode_for_spec (&expr
->ts
),
2775 arg
, build_int_cst (TREE_TYPE (arg
), value
));
2780 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2783 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2791 unsigned int num_args
;
2793 num_args
= gfc_intrinsic_argument_list_length (expr
);
2794 args
= alloca (sizeof (tree
) * num_args
);
2796 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2797 if (expr
->ts
.type
!= BT_CHARACTER
)
2805 /* We do the same as in the non-character case, but the argument
2806 list is different because of the string length arguments. We
2807 also have to set the string length for the result. */
2813 se
->string_length
= len
;
2815 type
= TREE_TYPE (tsource
);
2816 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2821 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2823 gfc_actual_arglist
*actual
;
2831 gfc_init_se (&argse
, NULL
);
2832 actual
= expr
->value
.function
.actual
;
2834 ss
= gfc_walk_expr (actual
->expr
);
2835 gcc_assert (ss
!= gfc_ss_terminator
);
2836 argse
.want_pointer
= 1;
2837 argse
.data_not_needed
= 1;
2838 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2839 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2840 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2841 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2843 /* Build the call to size0. */
2844 fncall0
= build_call_expr (gfor_fndecl_size0
, 1, arg1
);
2846 actual
= actual
->next
;
2850 gfc_init_se (&argse
, NULL
);
2851 gfc_conv_expr_type (&argse
, actual
->expr
,
2852 gfc_array_index_type
);
2853 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2855 /* Build the call to size1. */
2856 fncall1
= build_call_expr (gfor_fndecl_size1
, 2,
2859 /* Unusually, for an intrinsic, size does not exclude
2860 an optional arg2, so we must test for it. */
2861 if (actual
->expr
->expr_type
== EXPR_VARIABLE
2862 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
2863 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
2866 gfc_init_se (&argse
, NULL
);
2867 argse
.want_pointer
= 1;
2868 argse
.data_not_needed
= 1;
2869 gfc_conv_expr (&argse
, actual
->expr
);
2870 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2871 tmp
= build2 (NE_EXPR
, boolean_type_node
, argse
.expr
,
2873 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2874 se
->expr
= build3 (COND_EXPR
, pvoid_type_node
,
2875 tmp
, fncall1
, fncall0
);
2883 type
= gfc_typenode_for_spec (&expr
->ts
);
2884 se
->expr
= convert (type
, se
->expr
);
2889 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
2903 arg
= expr
->value
.function
.actual
->expr
;
2905 gfc_init_se (&argse
, NULL
);
2906 ss
= gfc_walk_expr (arg
);
2908 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
2910 if (ss
== gfc_ss_terminator
)
2912 gfc_conv_expr_reference (&argse
, arg
);
2913 source
= argse
.expr
;
2915 type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
2917 /* Obtain the source word length. */
2918 if (arg
->ts
.type
== BT_CHARACTER
)
2919 source_bytes
= fold_convert (gfc_array_index_type
,
2920 argse
.string_length
);
2922 source_bytes
= fold_convert (gfc_array_index_type
,
2923 size_in_bytes (type
));
2927 argse
.want_pointer
= 0;
2928 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2929 source
= gfc_conv_descriptor_data_get (argse
.expr
);
2930 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
2932 /* Obtain the argument's word length. */
2933 if (arg
->ts
.type
== BT_CHARACTER
)
2934 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
2936 tmp
= fold_convert (gfc_array_index_type
,
2937 size_in_bytes (type
));
2938 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2940 /* Obtain the size of the array in bytes. */
2941 for (n
= 0; n
< arg
->rank
; n
++)
2944 idx
= gfc_rank_cst
[n
];
2945 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
2946 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
2947 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2949 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2950 tmp
, gfc_index_one_node
);
2951 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2953 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2957 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2958 se
->expr
= source_bytes
;
2962 /* Intrinsic string comparison functions. */
2965 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2969 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
2971 se
->expr
= gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3]);
2972 se
->expr
= fold_build2 (op
, gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
2973 build_int_cst (TREE_TYPE (se
->expr
), 0));
2976 /* Generate a call to the adjustl/adjustr library function. */
2978 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2986 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
2989 type
= TREE_TYPE (args
[2]);
2990 var
= gfc_conv_string_tmp (se
, type
, len
);
2993 tmp
= build_call_expr (fndecl
, 3, args
[0], args
[1], args
[2]);
2994 gfc_add_expr_to_block (&se
->pre
, tmp
);
2996 se
->string_length
= len
;
3000 /* Array transfer statement.
3001 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3003 typeof<DEST> = typeof<MOLD>
3005 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3006 sizeof (DEST(0) * SIZE). */
3009 gfc_conv_intrinsic_array_transfer (gfc_se
* se
, gfc_expr
* expr
)
3024 gfc_actual_arglist
*arg
;
3031 gcc_assert (se
->loop
);
3032 info
= &se
->ss
->data
.info
;
3034 /* Convert SOURCE. The output from this stage is:-
3035 source_bytes = length of the source in bytes
3036 source = pointer to the source data. */
3037 arg
= expr
->value
.function
.actual
;
3038 gfc_init_se (&argse
, NULL
);
3039 ss
= gfc_walk_expr (arg
->expr
);
3041 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3043 /* Obtain the pointer to source and the length of source in bytes. */
3044 if (ss
== gfc_ss_terminator
)
3046 gfc_conv_expr_reference (&argse
, arg
->expr
);
3047 source
= argse
.expr
;
3049 source_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3051 /* Obtain the source word length. */
3052 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3053 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3055 tmp
= fold_convert (gfc_array_index_type
,
3056 size_in_bytes (source_type
));
3060 argse
.want_pointer
= 0;
3061 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3062 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3063 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3065 /* Repack the source if not a full variable array. */
3066 if (!(arg
->expr
->expr_type
== EXPR_VARIABLE
3067 && arg
->expr
->ref
->u
.ar
.type
== AR_FULL
))
3069 tmp
= build_fold_addr_expr (argse
.expr
);
3070 source
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
3071 source
= gfc_evaluate_now (source
, &argse
.pre
);
3073 /* Free the temporary. */
3074 gfc_start_block (&block
);
3075 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
3076 gfc_add_expr_to_block (&block
, tmp
);
3077 stmt
= gfc_finish_block (&block
);
3079 /* Clean up if it was repacked. */
3080 gfc_init_block (&block
);
3081 tmp
= gfc_conv_array_data (argse
.expr
);
3082 tmp
= build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
3083 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3084 gfc_add_expr_to_block (&block
, tmp
);
3085 gfc_add_block_to_block (&block
, &se
->post
);
3086 gfc_init_block (&se
->post
);
3087 gfc_add_block_to_block (&se
->post
, &block
);
3090 /* Obtain the source word length. */
3091 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3092 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3094 tmp
= fold_convert (gfc_array_index_type
,
3095 size_in_bytes (source_type
));
3097 /* Obtain the size of the array in bytes. */
3098 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
3099 for (n
= 0; n
< arg
->expr
->rank
; n
++)
3102 idx
= gfc_rank_cst
[n
];
3103 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3104 stride
= gfc_conv_descriptor_stride (argse
.expr
, idx
);
3105 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3106 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3107 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3109 gfc_add_modify_expr (&argse
.pre
, extent
, tmp
);
3110 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3111 extent
, gfc_index_one_node
);
3112 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3117 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3118 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3119 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3121 /* Now convert MOLD. The outputs are:
3122 mold_type = the TREE type of MOLD
3123 dest_word_len = destination word length in bytes. */
3126 gfc_init_se (&argse
, NULL
);
3127 ss
= gfc_walk_expr (arg
->expr
);
3129 if (ss
== gfc_ss_terminator
)
3131 gfc_conv_expr_reference (&argse
, arg
->expr
);
3132 mold_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3136 gfc_init_se (&argse
, NULL
);
3137 argse
.want_pointer
= 0;
3138 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3139 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3142 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3144 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3145 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
3148 tmp
= fold_convert (gfc_array_index_type
,
3149 size_in_bytes (mold_type
));
3151 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
3152 gfc_add_modify_expr (&se
->pre
, dest_word_len
, tmp
);
3154 /* Finally convert SIZE, if it is present. */
3156 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
3160 gfc_init_se (&argse
, NULL
);
3161 gfc_conv_expr_reference (&argse
, arg
->expr
);
3162 tmp
= convert (gfc_array_index_type
,
3163 build_fold_indirect_ref (argse
.expr
));
3164 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3165 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3170 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3171 if (tmp
!= NULL_TREE
)
3173 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3174 tmp
, dest_word_len
);
3175 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3181 gfc_add_modify_expr (&se
->pre
, size_bytes
, tmp
);
3182 gfc_add_modify_expr (&se
->pre
, size_words
,
3183 fold_build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
3184 size_bytes
, dest_word_len
));
3186 /* Evaluate the bounds of the result. If the loop range exists, we have
3187 to check if it is too large. If so, we modify loop->to be consistent
3188 with min(size, size(source)). Otherwise, size is made consistent with
3189 the loop range, so that the right number of bytes is transferred.*/
3190 n
= se
->loop
->order
[0];
3191 if (se
->loop
->to
[n
] != NULL_TREE
)
3193 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3194 se
->loop
->to
[n
], se
->loop
->from
[n
]);
3195 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3196 tmp
, gfc_index_one_node
);
3197 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3199 gfc_add_modify_expr (&se
->pre
, size_words
, tmp
);
3200 gfc_add_modify_expr (&se
->pre
, size_bytes
,
3201 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3202 size_words
, dest_word_len
));
3203 upper
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3204 size_words
, se
->loop
->from
[n
]);
3205 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3206 upper
, gfc_index_one_node
);
3210 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3211 size_words
, gfc_index_one_node
);
3212 se
->loop
->from
[n
] = gfc_index_zero_node
;
3215 se
->loop
->to
[n
] = upper
;
3217 /* Build a destination descriptor, using the pointer, source, as the
3218 data field. This is already allocated so set callee_alloc.
3219 FIXME callee_alloc is not set! */
3221 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
3222 info
, mold_type
, false, true, false);
3224 /* Cast the pointer to the result. */
3225 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3226 tmp
= fold_convert (pvoid_type_node
, tmp
);
3228 /* Use memcpy to do the transfer. */
3229 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
],
3232 fold_convert (pvoid_type_node
, source
),
3234 gfc_add_expr_to_block (&se
->pre
, tmp
);
3236 se
->expr
= info
->descriptor
;
3237 if (expr
->ts
.type
== BT_CHARACTER
)
3238 se
->string_length
= dest_word_len
;
3242 /* Scalar transfer statement.
3243 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3246 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
3248 gfc_actual_arglist
*arg
;
3255 /* Get a pointer to the source. */
3256 arg
= expr
->value
.function
.actual
;
3257 ss
= gfc_walk_expr (arg
->expr
);
3258 gfc_init_se (&argse
, NULL
);
3259 if (ss
== gfc_ss_terminator
)
3260 gfc_conv_expr_reference (&argse
, arg
->expr
);
3262 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
3263 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3264 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3268 type
= gfc_typenode_for_spec (&expr
->ts
);
3270 if (expr
->ts
.type
== BT_CHARACTER
)
3272 ptr
= convert (build_pointer_type (type
), ptr
);
3273 gfc_init_se (&argse
, NULL
);
3274 gfc_conv_expr (&argse
, arg
->expr
);
3275 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3276 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3278 se
->string_length
= argse
.string_length
;
3283 tmpdecl
= gfc_create_var (type
, "transfer");
3284 moldsize
= size_in_bytes (type
);
3286 /* Use memcpy to do the transfer. */
3287 tmp
= build1 (ADDR_EXPR
, build_pointer_type (type
), tmpdecl
);
3288 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
3289 fold_convert (pvoid_type_node
, tmp
),
3290 fold_convert (pvoid_type_node
, ptr
),
3292 gfc_add_expr_to_block (&se
->pre
, tmp
);
3299 /* Generate code for the ALLOCATED intrinsic.
3300 Generate inline code that directly check the address of the argument. */
3303 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
3305 gfc_actual_arglist
*arg1
;
3310 gfc_init_se (&arg1se
, NULL
);
3311 arg1
= expr
->value
.function
.actual
;
3312 ss1
= gfc_walk_expr (arg1
->expr
);
3313 arg1se
.descriptor_only
= 1;
3314 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3316 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3317 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
3318 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
3319 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
3323 /* Generate code for the ASSOCIATED intrinsic.
3324 If both POINTER and TARGET are arrays, generate a call to library function
3325 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3326 In other cases, generate inline code that directly compare the address of
3327 POINTER with the address of TARGET. */
3330 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
3332 gfc_actual_arglist
*arg1
;
3333 gfc_actual_arglist
*arg2
;
3338 tree nonzero_charlen
;
3339 tree nonzero_arraylen
;
3342 gfc_init_se (&arg1se
, NULL
);
3343 gfc_init_se (&arg2se
, NULL
);
3344 arg1
= expr
->value
.function
.actual
;
3346 ss1
= gfc_walk_expr (arg1
->expr
);
3350 /* No optional target. */
3351 if (ss1
== gfc_ss_terminator
)
3353 /* A pointer to a scalar. */
3354 arg1se
.want_pointer
= 1;
3355 gfc_conv_expr (&arg1se
, arg1
->expr
);
3360 /* A pointer to an array. */
3361 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3362 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3364 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3365 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3366 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
3367 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
3372 /* An optional target. */
3373 ss2
= gfc_walk_expr (arg2
->expr
);
3375 nonzero_charlen
= NULL_TREE
;
3376 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
3377 nonzero_charlen
= build2 (NE_EXPR
, boolean_type_node
,
3378 arg1
->expr
->ts
.cl
->backend_decl
,
3381 if (ss1
== gfc_ss_terminator
)
3383 /* A pointer to a scalar. */
3384 gcc_assert (ss2
== gfc_ss_terminator
);
3385 arg1se
.want_pointer
= 1;
3386 gfc_conv_expr (&arg1se
, arg1
->expr
);
3387 arg2se
.want_pointer
= 1;
3388 gfc_conv_expr (&arg2se
, arg2
->expr
);
3389 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3390 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3391 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
3392 tmp2
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
3394 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, tmp
, tmp2
);
3398 /* An array pointer of zero length is not associated if target is
3400 arg1se
.descriptor_only
= 1;
3401 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
3402 tmp
= gfc_conv_descriptor_stride (arg1se
.expr
,
3403 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
3404 nonzero_arraylen
= build2 (NE_EXPR
, boolean_type_node
,
3405 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
3407 /* A pointer to an array, call library function _gfor_associated. */
3408 gcc_assert (ss2
!= gfc_ss_terminator
);
3409 arg1se
.want_pointer
= 1;
3410 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3412 arg2se
.want_pointer
= 1;
3413 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
3414 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3415 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3416 se
->expr
= build_call_expr (gfor_fndecl_associated
, 2,
3417 arg1se
.expr
, arg2se
.expr
);
3418 se
->expr
= convert (boolean_type_node
, se
->expr
);
3419 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3420 se
->expr
, nonzero_arraylen
);
3423 /* If target is present zero character length pointers cannot
3425 if (nonzero_charlen
!= NULL_TREE
)
3426 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3427 se
->expr
, nonzero_charlen
);
3430 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3434 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3437 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
3441 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3443 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
3444 type
= gfc_get_int_type (4);
3445 arg
= build_fold_addr_expr (fold_convert (type
, arg
));
3447 /* Convert it to the required type. */
3448 type
= gfc_typenode_for_spec (&expr
->ts
);
3449 se
->expr
= build_call_expr (gfor_fndecl_si_kind
, 1, arg
);
3450 se
->expr
= fold_convert (type
, se
->expr
);
3454 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3457 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
3459 gfc_actual_arglist
*actual
;
3464 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3466 gfc_init_se (&argse
, se
);
3468 /* Pass a NULL pointer for an absent arg. */
3469 if (actual
->expr
== NULL
)
3470 argse
.expr
= null_pointer_node
;
3474 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3476 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
3477 ts
.type
= BT_INTEGER
;
3478 ts
.kind
= gfc_c_int_kind
;
3479 gfc_convert_type (actual
->expr
, &ts
, 2);
3481 gfc_conv_expr_reference (&argse
, actual
->expr
);
3484 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3485 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3486 args
= gfc_chainon_list (args
, argse
.expr
);
3489 /* Convert it to the required type. */
3490 type
= gfc_typenode_for_spec (&expr
->ts
);
3491 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
3492 se
->expr
= fold_convert (type
, se
->expr
);
3496 /* Generate code for TRIM (A) intrinsic function. */
3499 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
3501 tree gfc_int4_type_node
= gfc_get_int_type (4);
3510 unsigned int num_args
;
3512 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3513 args
= alloca (sizeof (tree
) * num_args
);
3515 type
= build_pointer_type (gfc_character1_type_node
);
3516 var
= gfc_create_var (type
, "pstr");
3517 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
3518 len
= gfc_create_var (gfc_int4_type_node
, "len");
3520 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3521 args
[0] = build_fold_addr_expr (len
);
3524 fndecl
= build_addr (gfor_fndecl_string_trim
, current_function_decl
);
3525 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim
)),
3526 fndecl
, num_args
, args
);
3527 gfc_add_expr_to_block (&se
->pre
, tmp
);
3529 /* Free the temporary afterwards, if necessary. */
3530 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
3531 build_int_cst (TREE_TYPE (len
), 0));
3532 tmp
= gfc_call_free (var
);
3533 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
3534 gfc_add_expr_to_block (&se
->post
, tmp
);
3537 se
->string_length
= len
;
3541 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3544 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
3546 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
3547 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
3548 stmtblock_t block
, body
;
3551 /* Get the arguments. */
3552 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3553 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
3555 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
3556 ncopies_type
= TREE_TYPE (ncopies
);
3558 /* Check that NCOPIES is not negative. */
3559 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
3560 build_int_cst (ncopies_type
, 0));
3561 gfc_trans_runtime_check (cond
, &se
->pre
, &expr
->where
,
3562 "Argument NCOPIES of REPEAT intrinsic is negative "
3563 "(its value is %lld)",
3564 fold_convert (long_integer_type_node
, ncopies
));
3566 /* If the source length is zero, any non negative value of NCOPIES
3567 is valid, and nothing happens. */
3568 n
= gfc_create_var (ncopies_type
, "ncopies");
3569 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
3570 build_int_cst (size_type_node
, 0));
3571 tmp
= fold_build3 (COND_EXPR
, ncopies_type
, cond
,
3572 build_int_cst (ncopies_type
, 0), ncopies
);
3573 gfc_add_modify_expr (&se
->pre
, n
, tmp
);
3576 /* Check that ncopies is not too large: ncopies should be less than
3577 (or equal to) MAX / slen, where MAX is the maximal integer of
3578 the gfc_charlen_type_node type. If slen == 0, we need a special
3579 case to avoid the division by zero. */
3580 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
3581 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
3582 max
= fold_build2 (TRUNC_DIV_EXPR
, size_type_node
,
3583 fold_convert (size_type_node
, max
), slen
);
3584 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
3585 ? size_type_node
: ncopies_type
;
3586 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
3587 fold_convert (largest
, ncopies
),
3588 fold_convert (largest
, max
));
3589 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
3590 build_int_cst (size_type_node
, 0));
3591 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
, boolean_false_node
,
3593 gfc_trans_runtime_check (cond
, &se
->pre
, &expr
->where
,
3594 "Argument NCOPIES of REPEAT intrinsic is too large");
3597 /* Compute the destination length. */
3598 dlen
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
3599 fold_convert (gfc_charlen_type_node
, slen
),
3600 fold_convert (gfc_charlen_type_node
, ncopies
));
3601 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
3602 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
3604 /* Generate the code to do the repeat operation:
3605 for (i = 0; i < ncopies; i++)
3606 memmove (dest + (i * slen), src, slen); */
3607 gfc_start_block (&block
);
3608 count
= gfc_create_var (ncopies_type
, "count");
3609 gfc_add_modify_expr (&block
, count
, build_int_cst (ncopies_type
, 0));
3610 exit_label
= gfc_build_label_decl (NULL_TREE
);
3612 /* Start the loop body. */
3613 gfc_start_block (&body
);
3615 /* Exit the loop if count >= ncopies. */
3616 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, count
, ncopies
);
3617 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3618 TREE_USED (exit_label
) = 1;
3619 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3620 build_empty_stmt ());
3621 gfc_add_expr_to_block (&body
, tmp
);
3623 /* Call memmove (dest + (i*slen), src, slen). */
3624 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
3625 fold_convert (gfc_charlen_type_node
, slen
),
3626 fold_convert (gfc_charlen_type_node
, count
));
3627 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
,
3628 fold_convert (pchar_type_node
, dest
),
3629 fold_convert (sizetype
, tmp
));
3630 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], 3,
3632 gfc_add_expr_to_block (&body
, tmp
);
3634 /* Increment count. */
3635 tmp
= build2 (PLUS_EXPR
, ncopies_type
, count
,
3636 build_int_cst (TREE_TYPE (count
), 1));
3637 gfc_add_modify_expr (&body
, count
, tmp
);
3639 /* Build the loop. */
3640 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
3641 gfc_add_expr_to_block (&block
, tmp
);
3643 /* Add the exit label. */
3644 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3645 gfc_add_expr_to_block (&block
, tmp
);
3647 /* Finish the block. */
3648 tmp
= gfc_finish_block (&block
);
3649 gfc_add_expr_to_block (&se
->pre
, tmp
);
3651 /* Set the result value. */
3653 se
->string_length
= dlen
;
3657 /* Generate code for the IARGC intrinsic. */
3660 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
3666 /* Call the library function. This always returns an INTEGER(4). */
3667 fndecl
= gfor_fndecl_iargc
;
3668 tmp
= build_call_expr (fndecl
, 0);
3670 /* Convert it to the required type. */
3671 type
= gfc_typenode_for_spec (&expr
->ts
);
3672 tmp
= fold_convert (type
, tmp
);
3678 /* The loc intrinsic returns the address of its argument as
3679 gfc_index_integer_kind integer. */
3682 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
3688 gcc_assert (!se
->ss
);
3690 arg_expr
= expr
->value
.function
.actual
->expr
;
3691 ss
= gfc_walk_expr (arg_expr
);
3692 if (ss
== gfc_ss_terminator
)
3693 gfc_conv_expr_reference (se
, arg_expr
);
3695 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1);
3696 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
3698 /* Create a temporary variable for loc return value. Without this,
3699 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
3700 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
3701 gfc_add_modify_expr (&se
->pre
, temp_var
, se
->expr
);
3702 se
->expr
= temp_var
;
3705 /* Generate code for an intrinsic function. Some map directly to library
3706 calls, others get special handling. In some cases the name of the function
3707 used depends on the type specifiers. */
3710 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
3712 gfc_intrinsic_sym
*isym
;
3716 isym
= expr
->value
.function
.isym
;
3718 name
= &expr
->value
.function
.name
[2];
3720 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
3722 lib
= gfc_is_intrinsic_libcall (expr
);
3726 se
->ignore_optional
= 1;
3727 gfc_conv_intrinsic_funcall (se
, expr
);
3732 switch (expr
->value
.function
.isym
->id
)
3737 case GFC_ISYM_REPEAT
:
3738 gfc_conv_intrinsic_repeat (se
, expr
);
3742 gfc_conv_intrinsic_trim (se
, expr
);
3745 case GFC_ISYM_SI_KIND
:
3746 gfc_conv_intrinsic_si_kind (se
, expr
);
3749 case GFC_ISYM_SR_KIND
:
3750 gfc_conv_intrinsic_sr_kind (se
, expr
);
3753 case GFC_ISYM_EXPONENT
:
3754 gfc_conv_intrinsic_exponent (se
, expr
);
3758 gfc_conv_intrinsic_index_scan_verify (se
, expr
, gfor_fndecl_string_scan
);
3761 case GFC_ISYM_VERIFY
:
3762 gfc_conv_intrinsic_index_scan_verify (se
, expr
, gfor_fndecl_string_verify
);
3765 case GFC_ISYM_ALLOCATED
:
3766 gfc_conv_allocated (se
, expr
);
3769 case GFC_ISYM_ASSOCIATED
:
3770 gfc_conv_associated(se
, expr
);
3774 gfc_conv_intrinsic_abs (se
, expr
);
3777 case GFC_ISYM_ADJUSTL
:
3778 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
3781 case GFC_ISYM_ADJUSTR
:
3782 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
3785 case GFC_ISYM_AIMAG
:
3786 gfc_conv_intrinsic_imagpart (se
, expr
);
3790 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
3794 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
3797 case GFC_ISYM_ANINT
:
3798 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
3802 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3806 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
3809 case GFC_ISYM_BTEST
:
3810 gfc_conv_intrinsic_btest (se
, expr
);
3813 case GFC_ISYM_ACHAR
:
3815 gfc_conv_intrinsic_char (se
, expr
);
3818 case GFC_ISYM_CONVERSION
:
3820 case GFC_ISYM_LOGICAL
:
3822 gfc_conv_intrinsic_conversion (se
, expr
);
3825 /* Integer conversions are handled separately to make sure we get the
3826 correct rounding mode. */
3831 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
3835 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
3838 case GFC_ISYM_CEILING
:
3839 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
3842 case GFC_ISYM_FLOOR
:
3843 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
3847 gfc_conv_intrinsic_mod (se
, expr
, 0);
3850 case GFC_ISYM_MODULO
:
3851 gfc_conv_intrinsic_mod (se
, expr
, 1);
3854 case GFC_ISYM_CMPLX
:
3855 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
3858 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
3859 gfc_conv_intrinsic_iargc (se
, expr
);
3862 case GFC_ISYM_COMPLEX
:
3863 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
3866 case GFC_ISYM_CONJG
:
3867 gfc_conv_intrinsic_conjg (se
, expr
);
3870 case GFC_ISYM_COUNT
:
3871 gfc_conv_intrinsic_count (se
, expr
);
3874 case GFC_ISYM_CTIME
:
3875 gfc_conv_intrinsic_ctime (se
, expr
);
3879 gfc_conv_intrinsic_dim (se
, expr
);
3882 case GFC_ISYM_DOT_PRODUCT
:
3883 gfc_conv_intrinsic_dot_product (se
, expr
);
3886 case GFC_ISYM_DPROD
:
3887 gfc_conv_intrinsic_dprod (se
, expr
);
3890 case GFC_ISYM_FDATE
:
3891 gfc_conv_intrinsic_fdate (se
, expr
);
3895 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3898 case GFC_ISYM_IBCLR
:
3899 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
3902 case GFC_ISYM_IBITS
:
3903 gfc_conv_intrinsic_ibits (se
, expr
);
3906 case GFC_ISYM_IBSET
:
3907 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
3910 case GFC_ISYM_IACHAR
:
3911 case GFC_ISYM_ICHAR
:
3912 /* We assume ASCII character sequence. */
3913 gfc_conv_intrinsic_ichar (se
, expr
);
3916 case GFC_ISYM_IARGC
:
3917 gfc_conv_intrinsic_iargc (se
, expr
);
3921 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3924 case GFC_ISYM_INDEX
:
3925 gfc_conv_intrinsic_index_scan_verify (se
, expr
, gfor_fndecl_string_index
);
3929 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3932 case GFC_ISYM_IS_IOSTAT_END
:
3933 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
3936 case GFC_ISYM_IS_IOSTAT_EOR
:
3937 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
3940 case GFC_ISYM_ISNAN
:
3941 gfc_conv_intrinsic_isnan (se
, expr
);
3944 case GFC_ISYM_LSHIFT
:
3945 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
3948 case GFC_ISYM_RSHIFT
:
3949 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
3952 case GFC_ISYM_ISHFT
:
3953 gfc_conv_intrinsic_ishft (se
, expr
);
3956 case GFC_ISYM_ISHFTC
:
3957 gfc_conv_intrinsic_ishftc (se
, expr
);
3960 case GFC_ISYM_LBOUND
:
3961 gfc_conv_intrinsic_bound (se
, expr
, 0);
3964 case GFC_ISYM_TRANSPOSE
:
3965 if (se
->ss
&& se
->ss
->useflags
)
3967 gfc_conv_tmp_array_ref (se
);
3968 gfc_advance_se_ss_chain (se
);
3971 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
3975 gfc_conv_intrinsic_len (se
, expr
);
3978 case GFC_ISYM_LEN_TRIM
:
3979 gfc_conv_intrinsic_len_trim (se
, expr
);
3983 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
3987 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
3991 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
3995 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
3999 if (expr
->ts
.type
== BT_CHARACTER
)
4000 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
4002 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
4005 case GFC_ISYM_MAXLOC
:
4006 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
4009 case GFC_ISYM_MAXVAL
:
4010 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
4013 case GFC_ISYM_MERGE
:
4014 gfc_conv_intrinsic_merge (se
, expr
);
4018 if (expr
->ts
.type
== BT_CHARACTER
)
4019 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
4021 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
4024 case GFC_ISYM_MINLOC
:
4025 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
4028 case GFC_ISYM_MINVAL
:
4029 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
4033 gfc_conv_intrinsic_not (se
, expr
);
4037 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4040 case GFC_ISYM_PRESENT
:
4041 gfc_conv_intrinsic_present (se
, expr
);
4044 case GFC_ISYM_PRODUCT
:
4045 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
4049 gfc_conv_intrinsic_sign (se
, expr
);
4053 gfc_conv_intrinsic_size (se
, expr
);
4056 case GFC_ISYM_SIZEOF
:
4057 gfc_conv_intrinsic_sizeof (se
, expr
);
4061 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
4064 case GFC_ISYM_TRANSFER
:
4067 if (se
->ss
->useflags
)
4069 /* Access the previously obtained result. */
4070 gfc_conv_tmp_array_ref (se
);
4071 gfc_advance_se_ss_chain (se
);
4075 gfc_conv_intrinsic_array_transfer (se
, expr
);
4078 gfc_conv_intrinsic_transfer (se
, expr
);
4081 case GFC_ISYM_TTYNAM
:
4082 gfc_conv_intrinsic_ttynam (se
, expr
);
4085 case GFC_ISYM_UBOUND
:
4086 gfc_conv_intrinsic_bound (se
, expr
, 1);
4090 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4094 gfc_conv_intrinsic_loc (se
, expr
);
4097 case GFC_ISYM_ACCESS
:
4098 case GFC_ISYM_CHDIR
:
4099 case GFC_ISYM_CHMOD
:
4100 case GFC_ISYM_DTIME
:
4101 case GFC_ISYM_ETIME
:
4103 case GFC_ISYM_FGETC
:
4106 case GFC_ISYM_FPUTC
:
4107 case GFC_ISYM_FSTAT
:
4108 case GFC_ISYM_FTELL
:
4109 case GFC_ISYM_GETCWD
:
4110 case GFC_ISYM_GETGID
:
4111 case GFC_ISYM_GETPID
:
4112 case GFC_ISYM_GETUID
:
4113 case GFC_ISYM_HOSTNM
:
4115 case GFC_ISYM_IERRNO
:
4116 case GFC_ISYM_IRAND
:
4117 case GFC_ISYM_ISATTY
:
4119 case GFC_ISYM_LSTAT
:
4120 case GFC_ISYM_MALLOC
:
4121 case GFC_ISYM_MATMUL
:
4122 case GFC_ISYM_MCLOCK
:
4123 case GFC_ISYM_MCLOCK8
:
4125 case GFC_ISYM_RENAME
:
4126 case GFC_ISYM_SECOND
:
4127 case GFC_ISYM_SECNDS
:
4128 case GFC_ISYM_SIGNAL
:
4130 case GFC_ISYM_SYMLNK
:
4131 case GFC_ISYM_SYSTEM
:
4133 case GFC_ISYM_TIME8
:
4134 case GFC_ISYM_UMASK
:
4135 case GFC_ISYM_UNLINK
:
4136 gfc_conv_intrinsic_funcall (se
, expr
);
4140 gfc_conv_intrinsic_lib_function (se
, expr
);
4146 /* This generates code to execute before entering the scalarization loop.
4147 Currently does nothing. */
4150 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
4152 switch (ss
->expr
->value
.function
.isym
->id
)
4154 case GFC_ISYM_UBOUND
:
4155 case GFC_ISYM_LBOUND
:
4164 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4165 inside the scalarization loop. */
4168 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
4172 /* The two argument version returns a scalar. */
4173 if (expr
->value
.function
.actual
->next
->expr
)
4176 newss
= gfc_get_ss ();
4177 newss
->type
= GFC_SS_INTRINSIC
;
4180 newss
->data
.info
.dimen
= 1;
4186 /* Walk an intrinsic array libcall. */
4189 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
4193 gcc_assert (expr
->rank
> 0);
4195 newss
= gfc_get_ss ();
4196 newss
->type
= GFC_SS_FUNCTION
;
4199 newss
->data
.info
.dimen
= expr
->rank
;
4205 /* Returns nonzero if the specified intrinsic function call maps directly to a
4206 an external library call. Should only be used for functions that return
4210 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
4212 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
4213 gcc_assert (expr
->rank
> 0);
4215 switch (expr
->value
.function
.isym
->id
)
4219 case GFC_ISYM_COUNT
:
4220 case GFC_ISYM_MATMUL
:
4221 case GFC_ISYM_MAXLOC
:
4222 case GFC_ISYM_MAXVAL
:
4223 case GFC_ISYM_MINLOC
:
4224 case GFC_ISYM_MINVAL
:
4225 case GFC_ISYM_PRODUCT
:
4227 case GFC_ISYM_SHAPE
:
4228 case GFC_ISYM_SPREAD
:
4229 case GFC_ISYM_TRANSPOSE
:
4230 /* Ignore absent optional parameters. */
4233 case GFC_ISYM_RESHAPE
:
4234 case GFC_ISYM_CSHIFT
:
4235 case GFC_ISYM_EOSHIFT
:
4237 case GFC_ISYM_UNPACK
:
4238 /* Pass absent optional parameters. */
4246 /* Walk an intrinsic function. */
4248 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
4249 gfc_intrinsic_sym
* isym
)
4253 if (isym
->elemental
)
4254 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
4256 if (expr
->rank
== 0)
4259 if (gfc_is_intrinsic_libcall (expr
))
4260 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4262 /* Special cases. */
4265 case GFC_ISYM_LBOUND
:
4266 case GFC_ISYM_UBOUND
:
4267 return gfc_walk_intrinsic_bound (ss
, expr
);
4269 case GFC_ISYM_TRANSFER
:
4270 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4273 /* This probably meant someone forgot to add an intrinsic to the above
4274 list(s) when they implemented it, or something's gone horribly
4280 #include "gt-fortran-trans-intrinsic.h"