1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
28 #include "coretypes.h"
33 #include "tree-gimple.h"
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 /* This maps fortran intrinsic math functions to external library or GCC
48 typedef struct gfc_intrinsic_map_t
GTY(())
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
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
);
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 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
313 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
316 build_round_expr (stmtblock_t
* pblock
, tree arg
, tree type
)
325 argtype
= TREE_TYPE (arg
);
326 arg
= gfc_evaluate_now (arg
, pblock
);
328 real_from_string (&r
, "0.5");
329 pos
= build_real (argtype
, r
);
331 real_from_string (&r
, "-0.5");
332 neg
= build_real (argtype
, r
);
334 tmp
= gfc_build_const (argtype
, integer_zero_node
);
335 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
337 tmp
= fold_build3 (COND_EXPR
, argtype
, cond
, pos
, neg
);
338 tmp
= fold_build2 (PLUS_EXPR
, argtype
, arg
, tmp
);
339 return fold_build1 (FIX_TRUNC_EXPR
, type
, tmp
);
343 /* Convert a real to an integer using a specific rounding mode.
344 Ideally we would just build the corresponding GENERIC node,
345 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
348 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
349 enum rounding_mode op
)
354 return build_fixbound_expr (pblock
, arg
, type
, 0);
358 return build_fixbound_expr (pblock
, arg
, type
, 1);
362 return build_round_expr (pblock
, arg
, type
);
365 gcc_assert (op
== RND_TRUNC
);
366 return build1 (FIX_TRUNC_EXPR
, type
, arg
);
371 /* Round a real value using the specified rounding mode.
372 We use a temporary integer of that same kind size as the result.
373 Values larger than those that can be represented by this kind are
374 unchanged, as they will not be accurate enough to represent the
376 huge = HUGE (KIND (a))
377 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
381 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
392 kind
= expr
->ts
.kind
;
395 /* We have builtin functions for some cases. */
438 /* Evaluate the argument. */
439 gcc_assert (expr
->value
.function
.actual
->expr
);
440 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
442 /* Use a builtin function if one exists. */
443 if (n
!= END_BUILTINS
)
445 tmp
= built_in_decls
[n
];
446 se
->expr
= build_call_expr (tmp
, 1, arg
);
450 /* This code is probably redundant, but we'll keep it lying around just
452 type
= gfc_typenode_for_spec (&expr
->ts
);
453 arg
= gfc_evaluate_now (arg
, &se
->pre
);
455 /* Test if the value is too large to handle sensibly. */
456 gfc_set_model_kind (kind
);
458 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
459 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
460 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
461 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
463 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
464 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
465 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
466 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
467 itype
= gfc_get_int_type (kind
);
469 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
470 tmp
= convert (type
, tmp
);
471 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
476 /* Convert to an integer using the specified rounding mode. */
479 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
485 nargs
= gfc_intrinsic_argument_list_length (expr
);
486 args
= alloca (sizeof (tree
) * nargs
);
488 /* Evaluate the argument, we process all arguments even though we only
489 use the first one for code generation purposes. */
490 type
= gfc_typenode_for_spec (&expr
->ts
);
491 gcc_assert (expr
->value
.function
.actual
->expr
);
492 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
494 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
496 /* Conversion to a different integer kind. */
497 se
->expr
= convert (type
, args
[0]);
501 /* Conversion from complex to non-complex involves taking the real
502 component of the value. */
503 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
504 && expr
->ts
.type
!= BT_COMPLEX
)
508 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
509 args
[0] = build1 (REALPART_EXPR
, artype
, args
[0]);
512 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
517 /* Get the imaginary component of a value. */
520 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
524 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
525 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
529 /* Get the complex conjugate of a value. */
532 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
536 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
537 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
541 /* Initialize function decls for library functions. The external functions
542 are created as required. Builtin functions are added here. */
545 gfc_build_intrinsic_lib_fndecls (void)
547 gfc_intrinsic_map_t
*m
;
549 /* Add GCC builtin functions. */
550 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
552 if (m
->code_r4
!= END_BUILTINS
)
553 m
->real4_decl
= built_in_decls
[m
->code_r4
];
554 if (m
->code_r8
!= END_BUILTINS
)
555 m
->real8_decl
= built_in_decls
[m
->code_r8
];
556 if (m
->code_r10
!= END_BUILTINS
)
557 m
->real10_decl
= built_in_decls
[m
->code_r10
];
558 if (m
->code_r16
!= END_BUILTINS
)
559 m
->real16_decl
= built_in_decls
[m
->code_r16
];
560 if (m
->code_c4
!= END_BUILTINS
)
561 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
562 if (m
->code_c8
!= END_BUILTINS
)
563 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
564 if (m
->code_c10
!= END_BUILTINS
)
565 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
566 if (m
->code_c16
!= END_BUILTINS
)
567 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
572 /* Create a fndecl for a simple intrinsic library function. */
575 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
580 gfc_actual_arglist
*actual
;
583 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
586 if (ts
->type
== BT_REAL
)
591 pdecl
= &m
->real4_decl
;
594 pdecl
= &m
->real8_decl
;
597 pdecl
= &m
->real10_decl
;
600 pdecl
= &m
->real16_decl
;
606 else if (ts
->type
== BT_COMPLEX
)
608 gcc_assert (m
->complex_available
);
613 pdecl
= &m
->complex4_decl
;
616 pdecl
= &m
->complex8_decl
;
619 pdecl
= &m
->complex10_decl
;
622 pdecl
= &m
->complex16_decl
;
637 snprintf (name
, sizeof (name
), "%s%s%s",
638 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
639 else if (ts
->kind
== 8)
640 snprintf (name
, sizeof (name
), "%s%s",
641 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
644 gcc_assert (ts
->kind
== 10 || ts
->kind
== 16);
645 snprintf (name
, sizeof (name
), "%s%s%s",
646 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
651 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
652 ts
->type
== BT_COMPLEX
? 'c' : 'r',
656 argtypes
= NULL_TREE
;
657 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
659 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
660 argtypes
= gfc_chainon_list (argtypes
, type
);
662 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
663 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
664 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
666 /* Mark the decl as external. */
667 DECL_EXTERNAL (fndecl
) = 1;
668 TREE_PUBLIC (fndecl
) = 1;
670 /* Mark it __attribute__((const)), if possible. */
671 TREE_READONLY (fndecl
) = m
->is_constant
;
673 rest_of_decl_compilation (fndecl
, 1, 0);
680 /* Convert an intrinsic function into an external or builtin call. */
683 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
685 gfc_intrinsic_map_t
*m
;
689 unsigned int num_args
;
692 id
= expr
->value
.function
.isym
->id
;
693 /* Find the entry for this function. */
694 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
700 if (m
->id
== GFC_ISYM_NONE
)
702 internal_error ("Intrinsic function %s(%d) not recognized",
703 expr
->value
.function
.name
, id
);
706 /* Get the decl and generate the call. */
707 num_args
= gfc_intrinsic_argument_list_length (expr
);
708 args
= alloca (sizeof (tree
) * num_args
);
710 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
711 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
712 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
714 fndecl
= build_addr (fndecl
, current_function_decl
);
715 se
->expr
= build_call_array (rettype
, fndecl
, num_args
, args
);
718 /* Generate code for EXPONENT(X) intrinsic function. */
721 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
726 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
728 a1
= expr
->value
.function
.actual
->expr
;
732 fndecl
= gfor_fndecl_math_exponent4
;
735 fndecl
= gfor_fndecl_math_exponent8
;
738 fndecl
= gfor_fndecl_math_exponent10
;
741 fndecl
= gfor_fndecl_math_exponent16
;
747 se
->expr
= build_call_expr (fndecl
, 1, arg
);
750 /* Evaluate a single upper or lower bound. */
751 /* TODO: bound intrinsic generates way too much unnecessary code. */
754 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
756 gfc_actual_arglist
*arg
;
757 gfc_actual_arglist
*arg2
;
762 tree cond
, cond1
, cond2
, cond3
, cond4
, size
;
770 arg
= expr
->value
.function
.actual
;
775 /* Create an implicit second parameter from the loop variable. */
776 gcc_assert (!arg2
->expr
);
777 gcc_assert (se
->loop
->dimen
== 1);
778 gcc_assert (se
->ss
->expr
== expr
);
779 gfc_advance_se_ss_chain (se
);
780 bound
= se
->loop
->loopvar
[0];
781 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
786 /* use the passed argument. */
787 gcc_assert (arg
->next
->expr
);
788 gfc_init_se (&argse
, NULL
);
789 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
790 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
792 /* Convert from one based to zero based. */
793 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
797 /* TODO: don't re-evaluate the descriptor on each iteration. */
798 /* Get a descriptor for the first parameter. */
799 ss
= gfc_walk_expr (arg
->expr
);
800 gcc_assert (ss
!= gfc_ss_terminator
);
801 gfc_init_se (&argse
, NULL
);
802 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
803 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
804 gfc_add_block_to_block (&se
->post
, &argse
.post
);
808 if (INTEGER_CST_P (bound
))
812 hi
= TREE_INT_CST_HIGH (bound
);
813 low
= TREE_INT_CST_LOW (bound
);
814 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
815 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
816 "dimension index", upper
? "UBOUND" : "LBOUND",
821 if (flag_bounds_check
)
823 bound
= gfc_evaluate_now (bound
, &se
->pre
);
824 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
825 bound
, build_int_cst (TREE_TYPE (bound
), 0));
826 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
827 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
828 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
829 gfc_trans_runtime_check (cond
, gfc_msg_fault
, &se
->pre
, &expr
->where
);
833 ubound
= gfc_conv_descriptor_ubound (desc
, bound
);
834 lbound
= gfc_conv_descriptor_lbound (desc
, bound
);
836 /* Follow any component references. */
837 if (arg
->expr
->expr_type
== EXPR_VARIABLE
838 || arg
->expr
->expr_type
== EXPR_CONSTANT
)
840 as
= arg
->expr
->symtree
->n
.sym
->as
;
841 for (ref
= arg
->expr
->ref
; ref
; ref
= ref
->next
)
846 as
= ref
->u
.c
.component
->as
;
854 switch (ref
->u
.ar
.type
)
872 /* 13.14.53: Result value for LBOUND
874 Case (i): For an array section or for an array expression other than a
875 whole array or array structure component, LBOUND(ARRAY, DIM)
876 has the value 1. For a whole array or array structure
877 component, LBOUND(ARRAY, DIM) has the value:
878 (a) equal to the lower bound for subscript DIM of ARRAY if
879 dimension DIM of ARRAY does not have extent zero
880 or if ARRAY is an assumed-size array of rank DIM,
883 13.14.113: Result value for UBOUND
885 Case (i): For an array section or for an array expression other than a
886 whole array or array structure component, UBOUND(ARRAY, DIM)
887 has the value equal to the number of elements in the given
888 dimension; otherwise, it has a value equal to the upper bound
889 for subscript DIM of ARRAY if dimension DIM of ARRAY does
890 not have size zero and has value zero if dimension DIM has
895 tree stride
= gfc_conv_descriptor_stride (desc
, bound
);
897 cond1
= fold_build2 (GE_EXPR
, boolean_type_node
, ubound
, lbound
);
898 cond2
= fold_build2 (LE_EXPR
, boolean_type_node
, ubound
, lbound
);
900 cond3
= fold_build2 (GE_EXPR
, boolean_type_node
, stride
,
901 gfc_index_zero_node
);
902 cond3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond3
, cond1
);
904 cond4
= fold_build2 (LT_EXPR
, boolean_type_node
, stride
,
905 gfc_index_zero_node
);
906 cond4
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond4
, cond2
);
910 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
912 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
913 ubound
, gfc_index_zero_node
);
917 if (as
->type
== AS_ASSUMED_SIZE
)
918 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, bound
,
919 build_int_cst (TREE_TYPE (bound
),
920 arg
->expr
->rank
- 1));
922 cond
= boolean_false_node
;
924 cond1
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
925 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond1
);
927 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
928 lbound
, gfc_index_one_node
);
935 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
936 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
940 se
->expr
= gfc_index_one_node
;
943 type
= gfc_typenode_for_spec (&expr
->ts
);
944 se
->expr
= convert (type
, se
->expr
);
949 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
954 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
956 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
960 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (arg
), arg
);
964 switch (expr
->ts
.kind
)
979 se
->expr
= build_call_expr (built_in_decls
[n
], 1, arg
);
988 /* Create a complex value from one or two real components. */
991 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
997 unsigned int num_args
;
999 num_args
= gfc_intrinsic_argument_list_length (expr
);
1000 args
= alloca (sizeof (tree
) * num_args
);
1002 type
= gfc_typenode_for_spec (&expr
->ts
);
1003 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1004 real
= convert (TREE_TYPE (type
), args
[0]);
1006 imag
= convert (TREE_TYPE (type
), args
[1]);
1007 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1009 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1010 imag
= convert (TREE_TYPE (type
), imag
);
1013 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1015 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
1018 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1019 MODULO(A, P) = A - FLOOR (A / P) * P */
1020 /* TODO: MOD(x, 0) */
1023 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1034 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1036 switch (expr
->ts
.type
)
1039 /* Integer case is easy, we've got a builtin op. */
1040 type
= TREE_TYPE (args
[0]);
1043 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, args
[0], args
[1]);
1045 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, args
[0], args
[1]);
1050 /* Check if we have a builtin fmod. */
1051 switch (expr
->ts
.kind
)
1070 /* Use it if it exists. */
1071 if (n
!= END_BUILTINS
)
1073 tmp
= build_addr (built_in_decls
[n
], current_function_decl
);
1074 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls
[n
])),
1080 type
= TREE_TYPE (args
[0]);
1082 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1083 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1086 modulo = arg - floor (arg/arg2) * arg2, so
1087 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1089 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1090 thereby avoiding another division and retaining the accuracy
1091 of the builtin function. */
1092 if (n
!= END_BUILTINS
&& modulo
)
1094 tree zero
= gfc_build_const (type
, integer_zero_node
);
1095 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1096 test
= build2 (LT_EXPR
, boolean_type_node
, args
[0], zero
);
1097 test2
= build2 (LT_EXPR
, boolean_type_node
, args
[1], zero
);
1098 test2
= build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
1099 test
= build2 (NE_EXPR
, boolean_type_node
, tmp
, zero
);
1100 test
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1101 test
= gfc_evaluate_now (test
, &se
->pre
);
1102 se
->expr
= build3 (COND_EXPR
, type
, test
,
1103 build2 (PLUS_EXPR
, type
, tmp
, args
[1]), tmp
);
1107 /* If we do not have a built_in fmod, the calculation is going to
1108 have to be done longhand. */
1109 tmp
= build2 (RDIV_EXPR
, type
, args
[0], args
[1]);
1111 /* Test if the value is too large to handle sensibly. */
1112 gfc_set_model_kind (expr
->ts
.kind
);
1114 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1115 ikind
= expr
->ts
.kind
;
1118 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1119 ikind
= gfc_max_integer_kind
;
1121 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1122 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1123 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
1125 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1126 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1127 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
1128 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1130 itype
= gfc_get_int_type (ikind
);
1132 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1134 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1135 tmp
= convert (type
, tmp
);
1136 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, args
[0]);
1137 tmp
= build2 (MULT_EXPR
, type
, tmp
, args
[1]);
1138 se
->expr
= build2 (MINUS_EXPR
, type
, args
[0], tmp
);
1147 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1150 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1158 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1159 type
= TREE_TYPE (args
[0]);
1161 val
= build2 (MINUS_EXPR
, type
, args
[0], args
[1]);
1162 val
= gfc_evaluate_now (val
, &se
->pre
);
1164 zero
= gfc_build_const (type
, integer_zero_node
);
1165 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
1166 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
1170 /* SIGN(A, B) is absolute value of A times sign of B.
1171 The real value versions use library functions to ensure the correct
1172 handling of negative zero. Integer case implemented as:
1173 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1177 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1183 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1184 if (expr
->ts
.type
== BT_REAL
)
1186 switch (expr
->ts
.kind
)
1189 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
1192 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
1196 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
1201 se
->expr
= build_call_expr (tmp
, 2, args
[0], args
[1]);
1205 /* Having excluded floating point types, we know we are now dealing
1206 with signed integer types. */
1207 type
= TREE_TYPE (args
[0]);
1209 /* Args[0] is used multiple times below. */
1210 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1212 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1213 the signs of A and B are the same, and of all ones if they differ. */
1214 tmp
= fold_build2 (BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1215 tmp
= fold_build2 (RSHIFT_EXPR
, type
, tmp
,
1216 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1217 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1219 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1220 is all ones (i.e. -1). */
1221 se
->expr
= fold_build2 (BIT_XOR_EXPR
, type
,
1222 fold_build2 (PLUS_EXPR
, type
, args
[0], tmp
),
1227 /* Test for the presence of an optional argument. */
1230 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1234 arg
= expr
->value
.function
.actual
->expr
;
1235 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1236 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1237 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1241 /* Calculate the double precision product of two single precision values. */
1244 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1249 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1251 /* Convert the args to double precision before multiplying. */
1252 type
= gfc_typenode_for_spec (&expr
->ts
);
1253 args
[0] = convert (type
, args
[0]);
1254 args
[1] = convert (type
, args
[1]);
1255 se
->expr
= build2 (MULT_EXPR
, type
, args
[0], args
[1]);
1259 /* Return a length one character string containing an ascii character. */
1262 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1268 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1270 /* We currently don't support character types != 1. */
1271 gcc_assert (expr
->ts
.kind
== 1);
1272 type
= gfc_character1_type_node
;
1273 var
= gfc_create_var (type
, "char");
1275 arg
= convert (type
, arg
);
1276 gfc_add_modify_expr (&se
->pre
, var
, arg
);
1277 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1278 se
->string_length
= integer_one_node
;
1283 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1290 tree gfc_int8_type_node
= gfc_get_int_type (8);
1293 unsigned int num_args
;
1295 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1296 args
= alloca (sizeof (tree
) * num_args
);
1298 type
= build_pointer_type (gfc_character1_type_node
);
1299 var
= gfc_create_var (type
, "pstr");
1300 len
= gfc_create_var (gfc_int8_type_node
, "len");
1302 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1303 args
[0] = build_fold_addr_expr (var
);
1304 args
[1] = build_fold_addr_expr (len
);
1306 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
1307 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1308 fndecl
, num_args
, args
);
1309 gfc_add_expr_to_block (&se
->pre
, tmp
);
1311 /* Free the temporary afterwards, if necessary. */
1312 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1313 build_int_cst (TREE_TYPE (len
), 0));
1314 tmp
= gfc_call_free (var
);
1315 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1316 gfc_add_expr_to_block (&se
->post
, tmp
);
1319 se
->string_length
= len
;
1324 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1331 tree gfc_int4_type_node
= gfc_get_int_type (4);
1334 unsigned int num_args
;
1336 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1337 args
= alloca (sizeof (tree
) * num_args
);
1339 type
= build_pointer_type (gfc_character1_type_node
);
1340 var
= gfc_create_var (type
, "pstr");
1341 len
= gfc_create_var (gfc_int4_type_node
, "len");
1343 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1344 args
[0] = build_fold_addr_expr (var
);
1345 args
[1] = build_fold_addr_expr (len
);
1347 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1348 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1349 fndecl
, num_args
, args
);
1350 gfc_add_expr_to_block (&se
->pre
, tmp
);
1352 /* Free the temporary afterwards, if necessary. */
1353 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1354 build_int_cst (TREE_TYPE (len
), 0));
1355 tmp
= gfc_call_free (var
);
1356 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1357 gfc_add_expr_to_block (&se
->post
, tmp
);
1360 se
->string_length
= len
;
1364 /* Return a character string containing the tty name. */
1367 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1375 tree gfc_int4_type_node
= gfc_get_int_type (4);
1377 unsigned int num_args
;
1379 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1380 args
= alloca (sizeof (tree
) * num_args
);
1382 type
= build_pointer_type (gfc_character1_type_node
);
1383 var
= gfc_create_var (type
, "pstr");
1384 len
= gfc_create_var (gfc_int4_type_node
, "len");
1386 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1387 args
[0] = build_fold_addr_expr (var
);
1388 args
[1] = build_fold_addr_expr (len
);
1390 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1391 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1392 fndecl
, num_args
, args
);
1393 gfc_add_expr_to_block (&se
->pre
, tmp
);
1395 /* Free the temporary afterwards, if necessary. */
1396 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1397 build_int_cst (TREE_TYPE (len
), 0));
1398 tmp
= gfc_call_free (var
);
1399 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1400 gfc_add_expr_to_block (&se
->post
, tmp
);
1403 se
->string_length
= len
;
1407 /* Get the minimum/maximum value of all the parameters.
1408 minmax (a1, a2, a3, ...)
1410 if (a2 .op. a1 || isnan(a1))
1414 if (a3 .op. mvar || isnan(mvar))
1421 /* TODO: Mismatching types can occur when specific names are used.
1422 These should be handled during resolution. */
1424 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1434 gfc_actual_arglist
*argexpr
;
1438 nargs
= gfc_intrinsic_argument_list_length (expr
);
1439 args
= alloca (sizeof (tree
) * nargs
);
1441 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1442 type
= gfc_typenode_for_spec (&expr
->ts
);
1444 /* The first and second arguments should be present, if they are
1445 optional dummy arguments. */
1446 argexpr
= expr
->value
.function
.actual
;
1447 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1448 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1449 && TREE_CODE (args
[0]) == INDIRECT_REF
)
1451 /* Check the first argument. */
1455 asprintf (&msg
, "First argument of '%s' intrinsic should be present",
1456 expr
->symtree
->n
.sym
->name
);
1457 cond
= build2 (EQ_EXPR
, boolean_type_node
, TREE_OPERAND (args
[0], 0),
1458 build_int_cst (TREE_TYPE (TREE_OPERAND (args
[0], 0)), 0));
1459 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, &expr
->where
);
1463 if (argexpr
->next
->expr
->expr_type
== EXPR_VARIABLE
1464 && argexpr
->next
->expr
->symtree
->n
.sym
->attr
.optional
1465 && TREE_CODE (args
[1]) == INDIRECT_REF
)
1467 /* Check the second argument. */
1471 asprintf (&msg
, "Second argument of '%s' intrinsic should be present",
1472 expr
->symtree
->n
.sym
->name
);
1473 cond
= build2 (EQ_EXPR
, boolean_type_node
, TREE_OPERAND (args
[1], 0),
1474 build_int_cst (TREE_TYPE (TREE_OPERAND (args
[1], 0)), 0));
1475 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, &expr
->where
);
1480 if (TREE_TYPE (limit
) != type
)
1481 limit
= convert (type
, limit
);
1482 /* Only evaluate the argument once. */
1483 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1484 limit
= gfc_evaluate_now (limit
, &se
->pre
);
1486 mvar
= gfc_create_var (type
, "M");
1487 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1488 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1494 /* Handle absent optional arguments by ignoring the comparison. */
1495 if (i
> 0 && argexpr
->expr
->expr_type
== EXPR_VARIABLE
1496 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1497 && TREE_CODE (val
) == INDIRECT_REF
)
1498 cond
= build2 (NE_EXPR
, boolean_type_node
, TREE_OPERAND (val
, 0),
1499 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1504 /* Only evaluate the argument once. */
1505 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1506 val
= gfc_evaluate_now (val
, &se
->pre
);
1509 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1511 tmp
= build2 (op
, boolean_type_node
, convert (type
, val
), limit
);
1513 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1514 __builtin_isnan might be made dependent on that module being loaded,
1515 to help performance of programs that don't rely on IEEE semantics. */
1516 if (FLOAT_TYPE_P (TREE_TYPE (limit
)))
1518 isnan
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, limit
);
1519 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, isnan
);
1521 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1523 if (cond
!= NULL_TREE
)
1524 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1526 gfc_add_expr_to_block (&se
->pre
, tmp
);
1527 elsecase
= build_empty_stmt ();
1529 argexpr
= argexpr
->next
;
1535 /* Create a symbol node for this intrinsic. The symbol from the frontend
1536 has the generic name. */
1539 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1543 /* TODO: Add symbols for intrinsic function to the global namespace. */
1544 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1545 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1548 sym
->attr
.external
= 1;
1549 sym
->attr
.function
= 1;
1550 sym
->attr
.always_explicit
= 1;
1551 sym
->attr
.proc
= PROC_INTRINSIC
;
1552 sym
->attr
.flavor
= FL_PROCEDURE
;
1556 sym
->attr
.dimension
= 1;
1557 sym
->as
= gfc_get_array_spec ();
1558 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1559 sym
->as
->rank
= expr
->rank
;
1562 /* TODO: proper argument lists for external intrinsics. */
1566 /* Generate a call to an external intrinsic function. */
1568 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1573 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1576 gcc_assert (expr
->rank
> 0);
1578 gcc_assert (expr
->rank
== 0);
1580 sym
= gfc_get_symbol_for_expr (expr
);
1582 /* Calls to libgfortran_matmul need to be appended special arguments,
1583 to be able to call the BLAS ?gemm functions if required and possible. */
1584 append_args
= NULL_TREE
;
1585 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1586 && sym
->ts
.type
!= BT_LOGICAL
)
1588 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1590 if (gfc_option
.flag_external_blas
1591 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1592 && (sym
->ts
.kind
== gfc_default_real_kind
1593 || sym
->ts
.kind
== gfc_default_double_kind
))
1597 if (sym
->ts
.type
== BT_REAL
)
1599 if (sym
->ts
.kind
== gfc_default_real_kind
)
1600 gemm_fndecl
= gfor_fndecl_sgemm
;
1602 gemm_fndecl
= gfor_fndecl_dgemm
;
1606 if (sym
->ts
.kind
== gfc_default_real_kind
)
1607 gemm_fndecl
= gfor_fndecl_cgemm
;
1609 gemm_fndecl
= gfor_fndecl_zgemm
;
1612 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 1));
1613 append_args
= gfc_chainon_list
1614 (append_args
, build_int_cst
1615 (cint
, gfc_option
.blas_matmul_limit
));
1616 append_args
= gfc_chainon_list (append_args
,
1617 gfc_build_addr_expr (NULL_TREE
,
1622 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 0));
1623 append_args
= gfc_chainon_list (append_args
, build_int_cst (cint
, 0));
1624 append_args
= gfc_chainon_list (append_args
, null_pointer_node
);
1628 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
1632 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1652 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1661 gfc_actual_arglist
*actual
;
1668 gfc_conv_intrinsic_funcall (se
, expr
);
1672 actual
= expr
->value
.function
.actual
;
1673 type
= gfc_typenode_for_spec (&expr
->ts
);
1674 /* Initialize the result. */
1675 resvar
= gfc_create_var (type
, "test");
1677 tmp
= convert (type
, boolean_true_node
);
1679 tmp
= convert (type
, boolean_false_node
);
1680 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1682 /* Walk the arguments. */
1683 arrayss
= gfc_walk_expr (actual
->expr
);
1684 gcc_assert (arrayss
!= gfc_ss_terminator
);
1686 /* Initialize the scalarizer. */
1687 gfc_init_loopinfo (&loop
);
1688 exit_label
= gfc_build_label_decl (NULL_TREE
);
1689 TREE_USED (exit_label
) = 1;
1690 gfc_add_ss_to_loop (&loop
, arrayss
);
1692 /* Initialize the loop. */
1693 gfc_conv_ss_startstride (&loop
);
1694 gfc_conv_loop_setup (&loop
);
1696 gfc_mark_ss_chain_used (arrayss
, 1);
1697 /* Generate the loop body. */
1698 gfc_start_scalarized_body (&loop
, &body
);
1700 /* If the condition matches then set the return value. */
1701 gfc_start_block (&block
);
1703 tmp
= convert (type
, boolean_false_node
);
1705 tmp
= convert (type
, boolean_true_node
);
1706 gfc_add_modify_expr (&block
, resvar
, tmp
);
1708 /* And break out of the loop. */
1709 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1710 gfc_add_expr_to_block (&block
, tmp
);
1712 found
= gfc_finish_block (&block
);
1714 /* Check this element. */
1715 gfc_init_se (&arrayse
, NULL
);
1716 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1717 arrayse
.ss
= arrayss
;
1718 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1720 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1721 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1722 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1723 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1724 gfc_add_expr_to_block (&body
, tmp
);
1725 gfc_add_block_to_block (&body
, &arrayse
.post
);
1727 gfc_trans_scalarizing_loops (&loop
, &body
);
1729 /* Add the exit label. */
1730 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1731 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1733 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1734 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1735 gfc_cleanup_loop (&loop
);
1740 /* COUNT(A) = Number of true elements in A. */
1742 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1749 gfc_actual_arglist
*actual
;
1755 gfc_conv_intrinsic_funcall (se
, expr
);
1759 actual
= expr
->value
.function
.actual
;
1761 type
= gfc_typenode_for_spec (&expr
->ts
);
1762 /* Initialize the result. */
1763 resvar
= gfc_create_var (type
, "count");
1764 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1766 /* Walk the arguments. */
1767 arrayss
= gfc_walk_expr (actual
->expr
);
1768 gcc_assert (arrayss
!= gfc_ss_terminator
);
1770 /* Initialize the scalarizer. */
1771 gfc_init_loopinfo (&loop
);
1772 gfc_add_ss_to_loop (&loop
, arrayss
);
1774 /* Initialize the loop. */
1775 gfc_conv_ss_startstride (&loop
);
1776 gfc_conv_loop_setup (&loop
);
1778 gfc_mark_ss_chain_used (arrayss
, 1);
1779 /* Generate the loop body. */
1780 gfc_start_scalarized_body (&loop
, &body
);
1782 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1783 build_int_cst (TREE_TYPE (resvar
), 1));
1784 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1786 gfc_init_se (&arrayse
, NULL
);
1787 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1788 arrayse
.ss
= arrayss
;
1789 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1790 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1792 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1793 gfc_add_expr_to_block (&body
, tmp
);
1794 gfc_add_block_to_block (&body
, &arrayse
.post
);
1796 gfc_trans_scalarizing_loops (&loop
, &body
);
1798 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1799 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1800 gfc_cleanup_loop (&loop
);
1805 /* Inline implementation of the sum and product intrinsics. */
1807 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1815 gfc_actual_arglist
*actual
;
1820 gfc_expr
*arrayexpr
;
1825 gfc_conv_intrinsic_funcall (se
, expr
);
1829 type
= gfc_typenode_for_spec (&expr
->ts
);
1830 /* Initialize the result. */
1831 resvar
= gfc_create_var (type
, "val");
1832 if (op
== PLUS_EXPR
)
1833 tmp
= gfc_build_const (type
, integer_zero_node
);
1835 tmp
= gfc_build_const (type
, integer_one_node
);
1837 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1839 /* Walk the arguments. */
1840 actual
= expr
->value
.function
.actual
;
1841 arrayexpr
= actual
->expr
;
1842 arrayss
= gfc_walk_expr (arrayexpr
);
1843 gcc_assert (arrayss
!= gfc_ss_terminator
);
1845 actual
= actual
->next
->next
;
1846 gcc_assert (actual
);
1847 maskexpr
= actual
->expr
;
1848 if (maskexpr
&& maskexpr
->rank
!= 0)
1850 maskss
= gfc_walk_expr (maskexpr
);
1851 gcc_assert (maskss
!= gfc_ss_terminator
);
1856 /* Initialize the scalarizer. */
1857 gfc_init_loopinfo (&loop
);
1858 gfc_add_ss_to_loop (&loop
, arrayss
);
1860 gfc_add_ss_to_loop (&loop
, maskss
);
1862 /* Initialize the loop. */
1863 gfc_conv_ss_startstride (&loop
);
1864 gfc_conv_loop_setup (&loop
);
1866 gfc_mark_ss_chain_used (arrayss
, 1);
1868 gfc_mark_ss_chain_used (maskss
, 1);
1869 /* Generate the loop body. */
1870 gfc_start_scalarized_body (&loop
, &body
);
1872 /* If we have a mask, only add this element if the mask is set. */
1875 gfc_init_se (&maskse
, NULL
);
1876 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1878 gfc_conv_expr_val (&maskse
, maskexpr
);
1879 gfc_add_block_to_block (&body
, &maskse
.pre
);
1881 gfc_start_block (&block
);
1884 gfc_init_block (&block
);
1886 /* Do the actual summation/product. */
1887 gfc_init_se (&arrayse
, NULL
);
1888 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1889 arrayse
.ss
= arrayss
;
1890 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1891 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1893 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1894 gfc_add_modify_expr (&block
, resvar
, tmp
);
1895 gfc_add_block_to_block (&block
, &arrayse
.post
);
1899 /* We enclose the above in if (mask) {...} . */
1900 tmp
= gfc_finish_block (&block
);
1902 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1905 tmp
= gfc_finish_block (&block
);
1906 gfc_add_expr_to_block (&body
, tmp
);
1908 gfc_trans_scalarizing_loops (&loop
, &body
);
1910 /* For a scalar mask, enclose the loop in an if statement. */
1911 if (maskexpr
&& maskss
== NULL
)
1913 gfc_init_se (&maskse
, NULL
);
1914 gfc_conv_expr_val (&maskse
, maskexpr
);
1915 gfc_init_block (&block
);
1916 gfc_add_block_to_block (&block
, &loop
.pre
);
1917 gfc_add_block_to_block (&block
, &loop
.post
);
1918 tmp
= gfc_finish_block (&block
);
1920 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1921 gfc_add_expr_to_block (&block
, tmp
);
1922 gfc_add_block_to_block (&se
->pre
, &block
);
1926 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1927 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1930 gfc_cleanup_loop (&loop
);
1936 /* Inline implementation of the dot_product intrinsic. This function
1937 is based on gfc_conv_intrinsic_arith (the previous function). */
1939 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1947 gfc_actual_arglist
*actual
;
1948 gfc_ss
*arrayss1
, *arrayss2
;
1949 gfc_se arrayse1
, arrayse2
;
1950 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1952 type
= gfc_typenode_for_spec (&expr
->ts
);
1954 /* Initialize the result. */
1955 resvar
= gfc_create_var (type
, "val");
1956 if (expr
->ts
.type
== BT_LOGICAL
)
1957 tmp
= build_int_cst (type
, 0);
1959 tmp
= gfc_build_const (type
, integer_zero_node
);
1961 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1963 /* Walk argument #1. */
1964 actual
= expr
->value
.function
.actual
;
1965 arrayexpr1
= actual
->expr
;
1966 arrayss1
= gfc_walk_expr (arrayexpr1
);
1967 gcc_assert (arrayss1
!= gfc_ss_terminator
);
1969 /* Walk argument #2. */
1970 actual
= actual
->next
;
1971 arrayexpr2
= actual
->expr
;
1972 arrayss2
= gfc_walk_expr (arrayexpr2
);
1973 gcc_assert (arrayss2
!= gfc_ss_terminator
);
1975 /* Initialize the scalarizer. */
1976 gfc_init_loopinfo (&loop
);
1977 gfc_add_ss_to_loop (&loop
, arrayss1
);
1978 gfc_add_ss_to_loop (&loop
, arrayss2
);
1980 /* Initialize the loop. */
1981 gfc_conv_ss_startstride (&loop
);
1982 gfc_conv_loop_setup (&loop
);
1984 gfc_mark_ss_chain_used (arrayss1
, 1);
1985 gfc_mark_ss_chain_used (arrayss2
, 1);
1987 /* Generate the loop body. */
1988 gfc_start_scalarized_body (&loop
, &body
);
1989 gfc_init_block (&block
);
1991 /* Make the tree expression for [conjg(]array1[)]. */
1992 gfc_init_se (&arrayse1
, NULL
);
1993 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
1994 arrayse1
.ss
= arrayss1
;
1995 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
1996 if (expr
->ts
.type
== BT_COMPLEX
)
1997 arrayse1
.expr
= build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
1998 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2000 /* Make the tree expression for array2. */
2001 gfc_init_se (&arrayse2
, NULL
);
2002 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2003 arrayse2
.ss
= arrayss2
;
2004 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2005 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2007 /* Do the actual product and sum. */
2008 if (expr
->ts
.type
== BT_LOGICAL
)
2010 tmp
= build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2011 tmp
= build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2015 tmp
= build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2016 tmp
= build2 (PLUS_EXPR
, type
, resvar
, tmp
);
2018 gfc_add_modify_expr (&block
, resvar
, tmp
);
2020 /* Finish up the loop block and the loop. */
2021 tmp
= gfc_finish_block (&block
);
2022 gfc_add_expr_to_block (&body
, tmp
);
2024 gfc_trans_scalarizing_loops (&loop
, &body
);
2025 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2026 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2027 gfc_cleanup_loop (&loop
);
2034 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
2038 stmtblock_t ifblock
;
2039 stmtblock_t elseblock
;
2047 gfc_actual_arglist
*actual
;
2052 gfc_expr
*arrayexpr
;
2059 gfc_conv_intrinsic_funcall (se
, expr
);
2063 /* Initialize the result. */
2064 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2065 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2066 type
= gfc_typenode_for_spec (&expr
->ts
);
2068 /* Walk the arguments. */
2069 actual
= expr
->value
.function
.actual
;
2070 arrayexpr
= actual
->expr
;
2071 arrayss
= gfc_walk_expr (arrayexpr
);
2072 gcc_assert (arrayss
!= gfc_ss_terminator
);
2074 actual
= actual
->next
->next
;
2075 gcc_assert (actual
);
2076 maskexpr
= actual
->expr
;
2077 if (maskexpr
&& maskexpr
->rank
!= 0)
2079 maskss
= gfc_walk_expr (maskexpr
);
2080 gcc_assert (maskss
!= gfc_ss_terminator
);
2085 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2086 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2087 switch (arrayexpr
->ts
.type
)
2090 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
2094 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2095 arrayexpr
->ts
.kind
);
2102 /* We start with the most negative possible value for MAXLOC, and the most
2103 positive possible value for MINLOC. The most negative possible value is
2104 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2105 possible value is HUGE in both cases. */
2107 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2108 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
2110 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2111 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2112 build_int_cst (type
, 1));
2114 /* Initialize the scalarizer. */
2115 gfc_init_loopinfo (&loop
);
2116 gfc_add_ss_to_loop (&loop
, arrayss
);
2118 gfc_add_ss_to_loop (&loop
, maskss
);
2120 /* Initialize the loop. */
2121 gfc_conv_ss_startstride (&loop
);
2122 gfc_conv_loop_setup (&loop
);
2124 gcc_assert (loop
.dimen
== 1);
2126 /* Initialize the position to zero, following Fortran 2003. We are free
2127 to do this because Fortran 95 allows the result of an entirely false
2128 mask to be processor dependent. */
2129 gfc_add_modify_expr (&loop
.pre
, pos
, gfc_index_zero_node
);
2131 gfc_mark_ss_chain_used (arrayss
, 1);
2133 gfc_mark_ss_chain_used (maskss
, 1);
2134 /* Generate the loop body. */
2135 gfc_start_scalarized_body (&loop
, &body
);
2137 /* If we have a mask, only check this element if the mask is set. */
2140 gfc_init_se (&maskse
, NULL
);
2141 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2143 gfc_conv_expr_val (&maskse
, maskexpr
);
2144 gfc_add_block_to_block (&body
, &maskse
.pre
);
2146 gfc_start_block (&block
);
2149 gfc_init_block (&block
);
2151 /* Compare with the current limit. */
2152 gfc_init_se (&arrayse
, NULL
);
2153 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2154 arrayse
.ss
= arrayss
;
2155 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2156 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2158 /* We do the following if this is a more extreme value. */
2159 gfc_start_block (&ifblock
);
2161 /* Assign the value to the limit... */
2162 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
2164 /* Remember where we are. An offset must be added to the loop
2165 counter to obtain the required position. */
2167 tmp
= build_int_cst (gfc_array_index_type
, 1);
2169 tmp
=fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2170 gfc_index_one_node
, loop
.from
[0]);
2171 gfc_add_modify_expr (&block
, offset
, tmp
);
2173 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2174 loop
.loopvar
[0], offset
);
2175 gfc_add_modify_expr (&ifblock
, pos
, tmp
);
2177 ifbody
= gfc_finish_block (&ifblock
);
2179 /* If it is a more extreme value or pos is still zero and the value
2180 equal to the limit. */
2181 tmp
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2182 build2 (EQ_EXPR
, boolean_type_node
, pos
, gfc_index_zero_node
),
2183 build2 (EQ_EXPR
, boolean_type_node
, arrayse
.expr
, limit
));
2184 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2185 build2 (op
, boolean_type_node
, arrayse
.expr
, limit
), tmp
);
2186 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2187 gfc_add_expr_to_block (&block
, tmp
);
2191 /* We enclose the above in if (mask) {...}. */
2192 tmp
= gfc_finish_block (&block
);
2194 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2197 tmp
= gfc_finish_block (&block
);
2198 gfc_add_expr_to_block (&body
, tmp
);
2200 gfc_trans_scalarizing_loops (&loop
, &body
);
2202 /* For a scalar mask, enclose the loop in an if statement. */
2203 if (maskexpr
&& maskss
== NULL
)
2205 gfc_init_se (&maskse
, NULL
);
2206 gfc_conv_expr_val (&maskse
, maskexpr
);
2207 gfc_init_block (&block
);
2208 gfc_add_block_to_block (&block
, &loop
.pre
);
2209 gfc_add_block_to_block (&block
, &loop
.post
);
2210 tmp
= gfc_finish_block (&block
);
2212 /* For the else part of the scalar mask, just initialize
2213 the pos variable the same way as above. */
2215 gfc_init_block (&elseblock
);
2216 gfc_add_modify_expr (&elseblock
, pos
, gfc_index_zero_node
);
2217 elsetmp
= gfc_finish_block (&elseblock
);
2219 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2220 gfc_add_expr_to_block (&block
, tmp
);
2221 gfc_add_block_to_block (&se
->pre
, &block
);
2225 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2226 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2228 gfc_cleanup_loop (&loop
);
2230 se
->expr
= convert (type
, pos
);
2234 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
2243 gfc_actual_arglist
*actual
;
2248 gfc_expr
*arrayexpr
;
2254 gfc_conv_intrinsic_funcall (se
, expr
);
2258 type
= gfc_typenode_for_spec (&expr
->ts
);
2259 /* Initialize the result. */
2260 limit
= gfc_create_var (type
, "limit");
2261 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2262 switch (expr
->ts
.type
)
2265 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
2269 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2276 /* We start with the most negative possible value for MAXVAL, and the most
2277 positive possible value for MINVAL. The most negative possible value is
2278 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2279 possible value is HUGE in both cases. */
2281 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2283 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2284 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2285 build_int_cst (type
, 1));
2287 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
2289 /* Walk the arguments. */
2290 actual
= expr
->value
.function
.actual
;
2291 arrayexpr
= actual
->expr
;
2292 arrayss
= gfc_walk_expr (arrayexpr
);
2293 gcc_assert (arrayss
!= gfc_ss_terminator
);
2295 actual
= actual
->next
->next
;
2296 gcc_assert (actual
);
2297 maskexpr
= actual
->expr
;
2298 if (maskexpr
&& maskexpr
->rank
!= 0)
2300 maskss
= gfc_walk_expr (maskexpr
);
2301 gcc_assert (maskss
!= gfc_ss_terminator
);
2306 /* Initialize the scalarizer. */
2307 gfc_init_loopinfo (&loop
);
2308 gfc_add_ss_to_loop (&loop
, arrayss
);
2310 gfc_add_ss_to_loop (&loop
, maskss
);
2312 /* Initialize the loop. */
2313 gfc_conv_ss_startstride (&loop
);
2314 gfc_conv_loop_setup (&loop
);
2316 gfc_mark_ss_chain_used (arrayss
, 1);
2318 gfc_mark_ss_chain_used (maskss
, 1);
2319 /* Generate the loop body. */
2320 gfc_start_scalarized_body (&loop
, &body
);
2322 /* If we have a mask, only add this element if the mask is set. */
2325 gfc_init_se (&maskse
, NULL
);
2326 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2328 gfc_conv_expr_val (&maskse
, maskexpr
);
2329 gfc_add_block_to_block (&body
, &maskse
.pre
);
2331 gfc_start_block (&block
);
2334 gfc_init_block (&block
);
2336 /* Compare with the current limit. */
2337 gfc_init_se (&arrayse
, NULL
);
2338 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2339 arrayse
.ss
= arrayss
;
2340 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2341 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2343 /* Assign the value to the limit... */
2344 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2346 /* If it is a more extreme value. */
2347 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2348 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2349 gfc_add_expr_to_block (&block
, tmp
);
2350 gfc_add_block_to_block (&block
, &arrayse
.post
);
2352 tmp
= gfc_finish_block (&block
);
2354 /* We enclose the above in if (mask) {...}. */
2355 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2356 gfc_add_expr_to_block (&body
, tmp
);
2358 gfc_trans_scalarizing_loops (&loop
, &body
);
2360 /* For a scalar mask, enclose the loop in an if statement. */
2361 if (maskexpr
&& maskss
== NULL
)
2363 gfc_init_se (&maskse
, NULL
);
2364 gfc_conv_expr_val (&maskse
, maskexpr
);
2365 gfc_init_block (&block
);
2366 gfc_add_block_to_block (&block
, &loop
.pre
);
2367 gfc_add_block_to_block (&block
, &loop
.post
);
2368 tmp
= gfc_finish_block (&block
);
2370 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2371 gfc_add_expr_to_block (&block
, tmp
);
2372 gfc_add_block_to_block (&se
->pre
, &block
);
2376 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2377 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2380 gfc_cleanup_loop (&loop
);
2385 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2387 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2393 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2394 type
= TREE_TYPE (args
[0]);
2396 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2397 tmp
= build2 (BIT_AND_EXPR
, type
, args
[0], tmp
);
2398 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2399 build_int_cst (type
, 0));
2400 type
= gfc_typenode_for_spec (&expr
->ts
);
2401 se
->expr
= convert (type
, tmp
);
2404 /* Generate code to perform the specified operation. */
2406 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
2410 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2411 se
->expr
= fold_build2 (op
, TREE_TYPE (args
[0]), args
[0], args
[1]);
2416 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2420 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2421 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2424 /* Set or clear a single bit. */
2426 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2433 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2434 type
= TREE_TYPE (args
[0]);
2436 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2442 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2444 se
->expr
= fold_build2 (op
, type
, args
[0], tmp
);
2447 /* Extract a sequence of bits.
2448 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2450 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2457 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2458 type
= TREE_TYPE (args
[0]);
2460 mask
= build_int_cst (type
, -1);
2461 mask
= build2 (LSHIFT_EXPR
, type
, mask
, args
[2]);
2462 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
2464 tmp
= build2 (RSHIFT_EXPR
, type
, args
[0], args
[1]);
2466 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2469 /* RSHIFT (I, SHIFT) = I >> SHIFT
2470 LSHIFT (I, SHIFT) = I << SHIFT */
2472 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
2476 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2478 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
2479 TREE_TYPE (args
[0]), args
[0], args
[1]);
2482 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2484 : ((shift >= 0) ? i << shift : i >> -shift)
2485 where all shifts are logical shifts. */
2487 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2499 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2500 type
= TREE_TYPE (args
[0]);
2501 utype
= unsigned_type_for (type
);
2503 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2505 /* Left shift if positive. */
2506 lshift
= fold_build2 (LSHIFT_EXPR
, type
, args
[0], width
);
2508 /* Right shift if negative.
2509 We convert to an unsigned type because we want a logical shift.
2510 The standard doesn't define the case of shifting negative
2511 numbers, and we try to be compatible with other compilers, most
2512 notably g77, here. */
2513 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
2514 convert (utype
, args
[0]), width
));
2516 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, args
[1],
2517 build_int_cst (TREE_TYPE (args
[1]), 0));
2518 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2520 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2521 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2523 num_bits
= build_int_cst (TREE_TYPE (args
[0]), TYPE_PRECISION (type
));
2524 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2526 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2527 build_int_cst (type
, 0), tmp
);
2530 /* Circular shift. AKA rotate or barrel shift. */
2532 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2540 unsigned int num_args
;
2542 num_args
= gfc_intrinsic_argument_list_length (expr
);
2543 args
= alloca (sizeof (tree
) * num_args
);
2545 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2549 /* Use a library function for the 3 parameter version. */
2550 tree int4type
= gfc_get_int_type (4);
2552 type
= TREE_TYPE (args
[0]);
2553 /* We convert the first argument to at least 4 bytes, and
2554 convert back afterwards. This removes the need for library
2555 functions for all argument sizes, and function will be
2556 aligned to at least 32 bits, so there's no loss. */
2557 if (expr
->ts
.kind
< 4)
2558 args
[0] = convert (int4type
, args
[0]);
2560 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2561 need loads of library functions. They cannot have values >
2562 BIT_SIZE (I) so the conversion is safe. */
2563 args
[1] = convert (int4type
, args
[1]);
2564 args
[2] = convert (int4type
, args
[2]);
2566 switch (expr
->ts
.kind
)
2571 tmp
= gfor_fndecl_math_ishftc4
;
2574 tmp
= gfor_fndecl_math_ishftc8
;
2577 tmp
= gfor_fndecl_math_ishftc16
;
2582 se
->expr
= build_call_expr (tmp
, 3, args
[0], args
[1], args
[2]);
2583 /* Convert the result back to the original type, if we extended
2584 the first argument's width above. */
2585 if (expr
->ts
.kind
< 4)
2586 se
->expr
= convert (type
, se
->expr
);
2590 type
= TREE_TYPE (args
[0]);
2592 /* Rotate left if positive. */
2593 lrot
= fold_build2 (LROTATE_EXPR
, type
, args
[0], args
[1]);
2595 /* Rotate right if negative. */
2596 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2597 rrot
= fold_build2 (RROTATE_EXPR
, type
, args
[0], tmp
);
2599 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
2600 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, args
[1], zero
);
2601 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2603 /* Do nothing if shift == 0. */
2604 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
2605 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, args
[0], rrot
);
2608 /* The length of a character string. */
2610 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2620 gcc_assert (!se
->ss
);
2622 arg
= expr
->value
.function
.actual
->expr
;
2624 type
= gfc_typenode_for_spec (&expr
->ts
);
2625 switch (arg
->expr_type
)
2628 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2632 /* Obtain the string length from the function used by
2633 trans-array.c(gfc_trans_array_constructor). */
2635 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
2639 if (arg
->ref
== NULL
2640 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
2642 /* This doesn't catch all cases.
2643 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2644 and the surrounding thread. */
2645 sym
= arg
->symtree
->n
.sym
;
2646 decl
= gfc_get_symbol_decl (sym
);
2647 if (decl
== current_function_decl
&& sym
->attr
.function
2648 && (sym
->result
== sym
))
2649 decl
= gfc_get_fake_result_decl (sym
, 0);
2651 len
= sym
->ts
.cl
->backend_decl
;
2656 /* Otherwise fall through. */
2659 /* Anybody stupid enough to do this deserves inefficient code. */
2660 ss
= gfc_walk_expr (arg
);
2661 gfc_init_se (&argse
, se
);
2662 if (ss
== gfc_ss_terminator
)
2663 gfc_conv_expr (&argse
, arg
);
2665 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2666 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2667 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2668 len
= argse
.string_length
;
2671 se
->expr
= convert (type
, len
);
2674 /* The length of a character string not including trailing blanks. */
2676 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2681 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2682 type
= gfc_typenode_for_spec (&expr
->ts
);
2683 se
->expr
= build_call_expr (gfor_fndecl_string_len_trim
, 2, args
[0], args
[1]);
2684 se
->expr
= convert (type
, se
->expr
);
2688 /* Returns the starting position of a substring within a string. */
2691 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
2693 tree logical4_type_node
= gfc_get_logical_type (4);
2697 unsigned int num_args
;
2699 num_args
= gfc_intrinsic_argument_list_length (expr
);
2700 args
= alloca (sizeof (tree
) * 5);
2702 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2703 type
= gfc_typenode_for_spec (&expr
->ts
);
2706 args
[4] = build_int_cst (logical4_type_node
, 0);
2709 gcc_assert (num_args
== 5);
2710 args
[4] = convert (logical4_type_node
, args
[4]);
2713 fndecl
= build_addr (gfor_fndecl_string_index
, current_function_decl
);
2714 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_index
)),
2716 se
->expr
= convert (type
, se
->expr
);
2720 /* The ascii value for a single character. */
2722 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2727 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2728 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
2729 args
[1] = build1 (NOP_EXPR
, pchar_type_node
, args
[1]);
2730 type
= gfc_typenode_for_spec (&expr
->ts
);
2732 se
->expr
= build_fold_indirect_ref (args
[1]);
2733 se
->expr
= convert (type
, se
->expr
);
2737 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2740 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2748 unsigned int num_args
;
2750 num_args
= gfc_intrinsic_argument_list_length (expr
);
2751 args
= alloca (sizeof (tree
) * num_args
);
2753 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2754 if (expr
->ts
.type
!= BT_CHARACTER
)
2762 /* We do the same as in the non-character case, but the argument
2763 list is different because of the string length arguments. We
2764 also have to set the string length for the result. */
2770 se
->string_length
= len
;
2772 type
= TREE_TYPE (tsource
);
2773 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2778 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2780 gfc_actual_arglist
*actual
;
2788 gfc_init_se (&argse
, NULL
);
2789 actual
= expr
->value
.function
.actual
;
2791 ss
= gfc_walk_expr (actual
->expr
);
2792 gcc_assert (ss
!= gfc_ss_terminator
);
2793 argse
.want_pointer
= 1;
2794 argse
.data_not_needed
= 1;
2795 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2796 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2797 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2798 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2800 /* Build the call to size0. */
2801 fncall0
= build_call_expr (gfor_fndecl_size0
, 1, arg1
);
2803 actual
= actual
->next
;
2807 gfc_init_se (&argse
, NULL
);
2808 gfc_conv_expr_type (&argse
, actual
->expr
,
2809 gfc_array_index_type
);
2810 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2812 /* Build the call to size1. */
2813 fncall1
= build_call_expr (gfor_fndecl_size1
, 2,
2816 /* Unusually, for an intrinsic, size does not exclude
2817 an optional arg2, so we must test for it. */
2818 if (actual
->expr
->expr_type
== EXPR_VARIABLE
2819 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
2820 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
2823 gfc_init_se (&argse
, NULL
);
2824 argse
.want_pointer
= 1;
2825 argse
.data_not_needed
= 1;
2826 gfc_conv_expr (&argse
, actual
->expr
);
2827 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2828 tmp
= build2 (NE_EXPR
, boolean_type_node
, argse
.expr
,
2830 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2831 se
->expr
= build3 (COND_EXPR
, pvoid_type_node
,
2832 tmp
, fncall1
, fncall0
);
2840 type
= gfc_typenode_for_spec (&expr
->ts
);
2841 se
->expr
= convert (type
, se
->expr
);
2846 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
2860 arg
= expr
->value
.function
.actual
->expr
;
2862 gfc_init_se (&argse
, NULL
);
2863 ss
= gfc_walk_expr (arg
);
2865 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
2867 if (ss
== gfc_ss_terminator
)
2869 gfc_conv_expr_reference (&argse
, arg
);
2870 source
= argse
.expr
;
2872 type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
2874 /* Obtain the source word length. */
2875 if (arg
->ts
.type
== BT_CHARACTER
)
2876 source_bytes
= fold_convert (gfc_array_index_type
,
2877 argse
.string_length
);
2879 source_bytes
= fold_convert (gfc_array_index_type
,
2880 size_in_bytes (type
));
2884 argse
.want_pointer
= 0;
2885 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2886 source
= gfc_conv_descriptor_data_get (argse
.expr
);
2887 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
2889 /* Obtain the argument's word length. */
2890 if (arg
->ts
.type
== BT_CHARACTER
)
2891 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
2893 tmp
= fold_convert (gfc_array_index_type
,
2894 size_in_bytes (type
));
2895 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2897 /* Obtain the size of the array in bytes. */
2898 for (n
= 0; n
< arg
->rank
; n
++)
2901 idx
= gfc_rank_cst
[n
];
2902 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
2903 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
2904 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2906 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2907 tmp
, gfc_index_one_node
);
2908 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2910 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2914 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2915 se
->expr
= source_bytes
;
2919 /* Intrinsic string comparison functions. */
2922 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2927 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
2929 se
->expr
= gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3]);
2930 type
= gfc_typenode_for_spec (&expr
->ts
);
2931 se
->expr
= fold_build2 (op
, type
, se
->expr
,
2932 build_int_cst (TREE_TYPE (se
->expr
), 0));
2935 /* Generate a call to the adjustl/adjustr library function. */
2937 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2945 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
2948 type
= TREE_TYPE (args
[2]);
2949 var
= gfc_conv_string_tmp (se
, type
, len
);
2952 tmp
= build_call_expr (fndecl
, 3, args
[0], args
[1], args
[2]);
2953 gfc_add_expr_to_block (&se
->pre
, tmp
);
2955 se
->string_length
= len
;
2959 /* Array transfer statement.
2960 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2962 typeof<DEST> = typeof<MOLD>
2964 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2965 sizeof (DEST(0) * SIZE). */
2968 gfc_conv_intrinsic_array_transfer (gfc_se
* se
, gfc_expr
* expr
)
2983 gfc_actual_arglist
*arg
;
2990 gcc_assert (se
->loop
);
2991 info
= &se
->ss
->data
.info
;
2993 /* Convert SOURCE. The output from this stage is:-
2994 source_bytes = length of the source in bytes
2995 source = pointer to the source data. */
2996 arg
= expr
->value
.function
.actual
;
2997 gfc_init_se (&argse
, NULL
);
2998 ss
= gfc_walk_expr (arg
->expr
);
3000 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3002 /* Obtain the pointer to source and the length of source in bytes. */
3003 if (ss
== gfc_ss_terminator
)
3005 gfc_conv_expr_reference (&argse
, arg
->expr
);
3006 source
= argse
.expr
;
3008 source_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3010 /* Obtain the source word length. */
3011 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3012 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3014 tmp
= fold_convert (gfc_array_index_type
,
3015 size_in_bytes (source_type
));
3019 argse
.want_pointer
= 0;
3020 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3021 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3022 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3024 /* Repack the source if not a full variable array. */
3025 if (!(arg
->expr
->expr_type
== EXPR_VARIABLE
3026 && arg
->expr
->ref
->u
.ar
.type
== AR_FULL
))
3028 tmp
= build_fold_addr_expr (argse
.expr
);
3029 source
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
3030 source
= gfc_evaluate_now (source
, &argse
.pre
);
3032 /* Free the temporary. */
3033 gfc_start_block (&block
);
3034 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
3035 gfc_add_expr_to_block (&block
, tmp
);
3036 stmt
= gfc_finish_block (&block
);
3038 /* Clean up if it was repacked. */
3039 gfc_init_block (&block
);
3040 tmp
= gfc_conv_array_data (argse
.expr
);
3041 tmp
= build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
3042 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3043 gfc_add_expr_to_block (&block
, tmp
);
3044 gfc_add_block_to_block (&block
, &se
->post
);
3045 gfc_init_block (&se
->post
);
3046 gfc_add_block_to_block (&se
->post
, &block
);
3049 /* Obtain the source word length. */
3050 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3051 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3053 tmp
= fold_convert (gfc_array_index_type
,
3054 size_in_bytes (source_type
));
3056 /* Obtain the size of the array in bytes. */
3057 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
3058 for (n
= 0; n
< arg
->expr
->rank
; n
++)
3061 idx
= gfc_rank_cst
[n
];
3062 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3063 stride
= gfc_conv_descriptor_stride (argse
.expr
, idx
);
3064 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3065 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3066 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3068 gfc_add_modify_expr (&argse
.pre
, extent
, tmp
);
3069 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3070 extent
, gfc_index_one_node
);
3071 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3076 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3077 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3078 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3080 /* Now convert MOLD. The outputs are:
3081 mold_type = the TREE type of MOLD
3082 dest_word_len = destination word length in bytes. */
3085 gfc_init_se (&argse
, NULL
);
3086 ss
= gfc_walk_expr (arg
->expr
);
3088 if (ss
== gfc_ss_terminator
)
3090 gfc_conv_expr_reference (&argse
, arg
->expr
);
3091 mold_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3095 gfc_init_se (&argse
, NULL
);
3096 argse
.want_pointer
= 0;
3097 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3098 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3101 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3103 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3104 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
3107 tmp
= fold_convert (gfc_array_index_type
,
3108 size_in_bytes (mold_type
));
3110 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
3111 gfc_add_modify_expr (&se
->pre
, dest_word_len
, tmp
);
3113 /* Finally convert SIZE, if it is present. */
3115 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
3119 gfc_init_se (&argse
, NULL
);
3120 gfc_conv_expr_reference (&argse
, arg
->expr
);
3121 tmp
= convert (gfc_array_index_type
,
3122 build_fold_indirect_ref (argse
.expr
));
3123 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3124 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3129 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3130 if (tmp
!= NULL_TREE
)
3132 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3133 tmp
, dest_word_len
);
3134 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3140 gfc_add_modify_expr (&se
->pre
, size_bytes
, tmp
);
3141 gfc_add_modify_expr (&se
->pre
, size_words
,
3142 fold_build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
3143 size_bytes
, dest_word_len
));
3145 /* Evaluate the bounds of the result. If the loop range exists, we have
3146 to check if it is too large. If so, we modify loop->to be consistent
3147 with min(size, size(source)). Otherwise, size is made consistent with
3148 the loop range, so that the right number of bytes is transferred.*/
3149 n
= se
->loop
->order
[0];
3150 if (se
->loop
->to
[n
] != NULL_TREE
)
3152 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3153 se
->loop
->to
[n
], se
->loop
->from
[n
]);
3154 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3155 tmp
, gfc_index_one_node
);
3156 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3158 gfc_add_modify_expr (&se
->pre
, size_words
, tmp
);
3159 gfc_add_modify_expr (&se
->pre
, size_bytes
,
3160 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3161 size_words
, dest_word_len
));
3162 upper
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3163 size_words
, se
->loop
->from
[n
]);
3164 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3165 upper
, gfc_index_one_node
);
3169 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3170 size_words
, gfc_index_one_node
);
3171 se
->loop
->from
[n
] = gfc_index_zero_node
;
3174 se
->loop
->to
[n
] = upper
;
3176 /* Build a destination descriptor, using the pointer, source, as the
3177 data field. This is already allocated so set callee_alloc.
3178 FIXME callee_alloc is not set! */
3180 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
3181 info
, mold_type
, false, true, false);
3183 /* Cast the pointer to the result. */
3184 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3185 tmp
= fold_convert (pvoid_type_node
, tmp
);
3187 /* Use memcpy to do the transfer. */
3188 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
],
3191 fold_convert (pvoid_type_node
, source
),
3193 gfc_add_expr_to_block (&se
->pre
, tmp
);
3195 se
->expr
= info
->descriptor
;
3196 if (expr
->ts
.type
== BT_CHARACTER
)
3197 se
->string_length
= dest_word_len
;
3201 /* Scalar transfer statement.
3202 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3205 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
3207 gfc_actual_arglist
*arg
;
3214 /* Get a pointer to the source. */
3215 arg
= expr
->value
.function
.actual
;
3216 ss
= gfc_walk_expr (arg
->expr
);
3217 gfc_init_se (&argse
, NULL
);
3218 if (ss
== gfc_ss_terminator
)
3219 gfc_conv_expr_reference (&argse
, arg
->expr
);
3221 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
3222 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3223 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3227 type
= gfc_typenode_for_spec (&expr
->ts
);
3229 if (expr
->ts
.type
== BT_CHARACTER
)
3231 ptr
= convert (build_pointer_type (type
), ptr
);
3232 gfc_init_se (&argse
, NULL
);
3233 gfc_conv_expr (&argse
, arg
->expr
);
3234 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3235 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3237 se
->string_length
= argse
.string_length
;
3242 tmpdecl
= gfc_create_var (type
, "transfer");
3243 moldsize
= size_in_bytes (type
);
3245 /* Use memcpy to do the transfer. */
3246 tmp
= build1 (ADDR_EXPR
, build_pointer_type (type
), tmpdecl
);
3247 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
3248 fold_convert (pvoid_type_node
, tmp
),
3249 fold_convert (pvoid_type_node
, ptr
),
3251 gfc_add_expr_to_block (&se
->pre
, tmp
);
3258 /* Generate code for the ALLOCATED intrinsic.
3259 Generate inline code that directly check the address of the argument. */
3262 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
3264 gfc_actual_arglist
*arg1
;
3269 gfc_init_se (&arg1se
, NULL
);
3270 arg1
= expr
->value
.function
.actual
;
3271 ss1
= gfc_walk_expr (arg1
->expr
);
3272 arg1se
.descriptor_only
= 1;
3273 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3275 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3276 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
3277 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
3278 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
3282 /* Generate code for the ASSOCIATED intrinsic.
3283 If both POINTER and TARGET are arrays, generate a call to library function
3284 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3285 In other cases, generate inline code that directly compare the address of
3286 POINTER with the address of TARGET. */
3289 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
3291 gfc_actual_arglist
*arg1
;
3292 gfc_actual_arglist
*arg2
;
3298 tree nonzero_charlen
;
3299 tree nonzero_arraylen
;
3302 gfc_init_se (&arg1se
, NULL
);
3303 gfc_init_se (&arg2se
, NULL
);
3304 arg1
= expr
->value
.function
.actual
;
3306 ss1
= gfc_walk_expr (arg1
->expr
);
3310 /* No optional target. */
3311 if (ss1
== gfc_ss_terminator
)
3313 /* A pointer to a scalar. */
3314 arg1se
.want_pointer
= 1;
3315 gfc_conv_expr (&arg1se
, arg1
->expr
);
3320 /* A pointer to an array. */
3321 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3322 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3324 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3325 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3326 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
3327 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
3332 /* An optional target. */
3333 ss2
= gfc_walk_expr (arg2
->expr
);
3335 nonzero_charlen
= NULL_TREE
;
3336 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
3337 nonzero_charlen
= build2 (NE_EXPR
, boolean_type_node
,
3338 arg1
->expr
->ts
.cl
->backend_decl
,
3341 if (ss1
== gfc_ss_terminator
)
3343 /* A pointer to a scalar. */
3344 gcc_assert (ss2
== gfc_ss_terminator
);
3345 arg1se
.want_pointer
= 1;
3346 gfc_conv_expr (&arg1se
, arg1
->expr
);
3347 arg2se
.want_pointer
= 1;
3348 gfc_conv_expr (&arg2se
, arg2
->expr
);
3349 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3350 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3351 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
3352 tmp2
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
3354 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, tmp
, tmp2
);
3359 /* An array pointer of zero length is not associated if target is
3361 arg1se
.descriptor_only
= 1;
3362 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
3363 tmp
= gfc_conv_descriptor_stride (arg1se
.expr
,
3364 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
3365 nonzero_arraylen
= build2 (NE_EXPR
, boolean_type_node
,
3366 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
3368 /* A pointer to an array, call library function _gfor_associated. */
3369 gcc_assert (ss2
!= gfc_ss_terminator
);
3370 arg1se
.want_pointer
= 1;
3371 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3373 arg2se
.want_pointer
= 1;
3374 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
3375 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3376 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3377 fndecl
= gfor_fndecl_associated
;
3378 se
->expr
= build_call_expr (fndecl
, 2, arg1se
.expr
, arg2se
.expr
);
3379 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3380 se
->expr
, nonzero_arraylen
);
3384 /* If target is present zero character length pointers cannot
3386 if (nonzero_charlen
!= NULL_TREE
)
3387 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3388 se
->expr
, nonzero_charlen
);
3391 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3395 /* Scan a string for any one of the characters in a set of characters. */
3398 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
3400 tree logical4_type_node
= gfc_get_logical_type (4);
3404 unsigned int num_args
;
3406 num_args
= gfc_intrinsic_argument_list_length (expr
);
3407 args
= alloca (sizeof (tree
) * 5);
3409 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3410 type
= gfc_typenode_for_spec (&expr
->ts
);
3413 args
[4] = build_int_cst (logical4_type_node
, 0);
3416 gcc_assert (num_args
== 5);
3417 args
[4] = convert (logical4_type_node
, args
[4]);
3420 fndecl
= build_addr (gfor_fndecl_string_scan
, current_function_decl
);
3421 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan
)),
3423 se
->expr
= convert (type
, se
->expr
);
3427 /* Verify that a set of characters contains all the characters in a string
3428 by identifying the position of the first character in a string of
3429 characters that does not appear in a given set of characters. */
3432 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
3434 tree logical4_type_node
= gfc_get_logical_type (4);
3438 unsigned int num_args
;
3440 num_args
= gfc_intrinsic_argument_list_length (expr
);
3441 args
= alloca (sizeof (tree
) * 5);
3443 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3444 type
= gfc_typenode_for_spec (&expr
->ts
);
3447 args
[4] = build_int_cst (logical4_type_node
, 0);
3450 gcc_assert (num_args
== 5);
3451 args
[4] = convert (logical4_type_node
, args
[4]);
3454 fndecl
= build_addr (gfor_fndecl_string_verify
, current_function_decl
);
3455 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify
)),
3458 se
->expr
= convert (type
, se
->expr
);
3462 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3465 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
3469 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3470 arg
= build_fold_addr_expr (arg
);
3471 se
->expr
= build_call_expr (gfor_fndecl_si_kind
, 1, arg
);
3474 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3477 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
3479 gfc_actual_arglist
*actual
;
3484 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3486 gfc_init_se (&argse
, se
);
3488 /* Pass a NULL pointer for an absent arg. */
3489 if (actual
->expr
== NULL
)
3490 argse
.expr
= null_pointer_node
;
3492 gfc_conv_expr_reference (&argse
, actual
->expr
);
3494 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3495 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3496 args
= gfc_chainon_list (args
, argse
.expr
);
3498 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
3502 /* Generate code for TRIM (A) intrinsic function. */
3505 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
3507 tree gfc_int4_type_node
= gfc_get_int_type (4);
3516 unsigned int num_args
;
3518 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3519 args
= alloca (sizeof (tree
) * num_args
);
3521 type
= build_pointer_type (gfc_character1_type_node
);
3522 var
= gfc_create_var (type
, "pstr");
3523 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
3524 len
= gfc_create_var (gfc_int4_type_node
, "len");
3526 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3527 args
[0] = build_fold_addr_expr (len
);
3530 fndecl
= build_addr (gfor_fndecl_string_trim
, current_function_decl
);
3531 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim
)),
3532 fndecl
, num_args
, args
);
3533 gfc_add_expr_to_block (&se
->pre
, tmp
);
3535 /* Free the temporary afterwards, if necessary. */
3536 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
3537 build_int_cst (TREE_TYPE (len
), 0));
3538 tmp
= gfc_call_free (var
);
3539 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
3540 gfc_add_expr_to_block (&se
->post
, tmp
);
3543 se
->string_length
= len
;
3547 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3550 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
3552 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
3553 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
3554 stmtblock_t block
, body
;
3557 /* Get the arguments. */
3558 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3559 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
3561 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
3562 ncopies_type
= TREE_TYPE (ncopies
);
3564 /* Check that NCOPIES is not negative. */
3565 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
3566 build_int_cst (ncopies_type
, 0));
3567 gfc_trans_runtime_check (cond
,
3568 "Argument NCOPIES of REPEAT intrinsic is negative",
3569 &se
->pre
, &expr
->where
);
3571 /* If the source length is zero, any non negative value of NCOPIES
3572 is valid, and nothing happens. */
3573 n
= gfc_create_var (ncopies_type
, "ncopies");
3574 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
3575 build_int_cst (size_type_node
, 0));
3576 tmp
= fold_build3 (COND_EXPR
, ncopies_type
, cond
,
3577 build_int_cst (ncopies_type
, 0), ncopies
);
3578 gfc_add_modify_expr (&se
->pre
, n
, tmp
);
3581 /* Check that ncopies is not too large: ncopies should be less than
3582 (or equal to) MAX / slen, where MAX is the maximal integer of
3583 the gfc_charlen_type_node type. If slen == 0, we need a special
3584 case to avoid the division by zero. */
3585 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
3586 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
3587 max
= fold_build2 (TRUNC_DIV_EXPR
, size_type_node
,
3588 fold_convert (size_type_node
, max
), slen
);
3589 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
3590 ? size_type_node
: ncopies_type
;
3591 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
3592 fold_convert (largest
, ncopies
),
3593 fold_convert (largest
, max
));
3594 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
3595 build_int_cst (size_type_node
, 0));
3596 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
, boolean_false_node
,
3598 gfc_trans_runtime_check (cond
,
3599 "Argument NCOPIES of REPEAT intrinsic is too large",
3600 &se
->pre
, &expr
->where
);
3602 /* Compute the destination length. */
3603 dlen
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
3604 fold_convert (gfc_charlen_type_node
, slen
),
3605 fold_convert (gfc_charlen_type_node
, ncopies
));
3606 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
3607 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
3609 /* Generate the code to do the repeat operation:
3610 for (i = 0; i < ncopies; i++)
3611 memmove (dest + (i * slen), src, slen); */
3612 gfc_start_block (&block
);
3613 count
= gfc_create_var (ncopies_type
, "count");
3614 gfc_add_modify_expr (&block
, count
, build_int_cst (ncopies_type
, 0));
3615 exit_label
= gfc_build_label_decl (NULL_TREE
);
3617 /* Start the loop body. */
3618 gfc_start_block (&body
);
3620 /* Exit the loop if count >= ncopies. */
3621 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, count
, ncopies
);
3622 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3623 TREE_USED (exit_label
) = 1;
3624 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3625 build_empty_stmt ());
3626 gfc_add_expr_to_block (&body
, tmp
);
3628 /* Call memmove (dest + (i*slen), src, slen). */
3629 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
3630 fold_convert (gfc_charlen_type_node
, slen
),
3631 fold_convert (gfc_charlen_type_node
, count
));
3632 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
,
3633 fold_convert (pchar_type_node
, dest
),
3634 fold_convert (sizetype
, tmp
));
3635 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], 3,
3637 gfc_add_expr_to_block (&body
, tmp
);
3639 /* Increment count. */
3640 tmp
= build2 (PLUS_EXPR
, ncopies_type
, count
,
3641 build_int_cst (TREE_TYPE (count
), 1));
3642 gfc_add_modify_expr (&body
, count
, tmp
);
3644 /* Build the loop. */
3645 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
3646 gfc_add_expr_to_block (&block
, tmp
);
3648 /* Add the exit label. */
3649 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3650 gfc_add_expr_to_block (&block
, tmp
);
3652 /* Finish the block. */
3653 tmp
= gfc_finish_block (&block
);
3654 gfc_add_expr_to_block (&se
->pre
, tmp
);
3656 /* Set the result value. */
3658 se
->string_length
= dlen
;
3662 /* Generate code for the IARGC intrinsic. */
3665 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
3671 /* Call the library function. This always returns an INTEGER(4). */
3672 fndecl
= gfor_fndecl_iargc
;
3673 tmp
= build_call_expr (fndecl
, 0);
3675 /* Convert it to the required type. */
3676 type
= gfc_typenode_for_spec (&expr
->ts
);
3677 tmp
= fold_convert (type
, tmp
);
3683 /* The loc intrinsic returns the address of its argument as
3684 gfc_index_integer_kind integer. */
3687 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
3693 gcc_assert (!se
->ss
);
3695 arg_expr
= expr
->value
.function
.actual
->expr
;
3696 ss
= gfc_walk_expr (arg_expr
);
3697 if (ss
== gfc_ss_terminator
)
3698 gfc_conv_expr_reference (se
, arg_expr
);
3700 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1);
3701 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
3703 /* Create a temporary variable for loc return value. Without this,
3704 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
3705 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
3706 gfc_add_modify_expr (&se
->pre
, temp_var
, se
->expr
);
3707 se
->expr
= temp_var
;
3710 /* Generate code for an intrinsic function. Some map directly to library
3711 calls, others get special handling. In some cases the name of the function
3712 used depends on the type specifiers. */
3715 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
3717 gfc_intrinsic_sym
*isym
;
3721 isym
= expr
->value
.function
.isym
;
3723 name
= &expr
->value
.function
.name
[2];
3725 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
3727 lib
= gfc_is_intrinsic_libcall (expr
);
3731 se
->ignore_optional
= 1;
3732 gfc_conv_intrinsic_funcall (se
, expr
);
3737 switch (expr
->value
.function
.isym
->id
)
3742 case GFC_ISYM_REPEAT
:
3743 gfc_conv_intrinsic_repeat (se
, expr
);
3747 gfc_conv_intrinsic_trim (se
, expr
);
3750 case GFC_ISYM_SI_KIND
:
3751 gfc_conv_intrinsic_si_kind (se
, expr
);
3754 case GFC_ISYM_SR_KIND
:
3755 gfc_conv_intrinsic_sr_kind (se
, expr
);
3758 case GFC_ISYM_EXPONENT
:
3759 gfc_conv_intrinsic_exponent (se
, expr
);
3763 gfc_conv_intrinsic_scan (se
, expr
);
3766 case GFC_ISYM_VERIFY
:
3767 gfc_conv_intrinsic_verify (se
, expr
);
3770 case GFC_ISYM_ALLOCATED
:
3771 gfc_conv_allocated (se
, expr
);
3774 case GFC_ISYM_ASSOCIATED
:
3775 gfc_conv_associated(se
, expr
);
3779 gfc_conv_intrinsic_abs (se
, expr
);
3782 case GFC_ISYM_ADJUSTL
:
3783 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
3786 case GFC_ISYM_ADJUSTR
:
3787 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
3790 case GFC_ISYM_AIMAG
:
3791 gfc_conv_intrinsic_imagpart (se
, expr
);
3795 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
3799 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
3802 case GFC_ISYM_ANINT
:
3803 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
3807 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3811 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
3814 case GFC_ISYM_BTEST
:
3815 gfc_conv_intrinsic_btest (se
, expr
);
3818 case GFC_ISYM_ACHAR
:
3820 gfc_conv_intrinsic_char (se
, expr
);
3823 case GFC_ISYM_CONVERSION
:
3825 case GFC_ISYM_LOGICAL
:
3827 gfc_conv_intrinsic_conversion (se
, expr
);
3830 /* Integer conversions are handled separately to make sure we get the
3831 correct rounding mode. */
3836 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
3840 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
3843 case GFC_ISYM_CEILING
:
3844 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
3847 case GFC_ISYM_FLOOR
:
3848 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
3852 gfc_conv_intrinsic_mod (se
, expr
, 0);
3855 case GFC_ISYM_MODULO
:
3856 gfc_conv_intrinsic_mod (se
, expr
, 1);
3859 case GFC_ISYM_CMPLX
:
3860 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
3863 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
3864 gfc_conv_intrinsic_iargc (se
, expr
);
3867 case GFC_ISYM_COMPLEX
:
3868 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
3871 case GFC_ISYM_CONJG
:
3872 gfc_conv_intrinsic_conjg (se
, expr
);
3875 case GFC_ISYM_COUNT
:
3876 gfc_conv_intrinsic_count (se
, expr
);
3879 case GFC_ISYM_CTIME
:
3880 gfc_conv_intrinsic_ctime (se
, expr
);
3884 gfc_conv_intrinsic_dim (se
, expr
);
3887 case GFC_ISYM_DOT_PRODUCT
:
3888 gfc_conv_intrinsic_dot_product (se
, expr
);
3891 case GFC_ISYM_DPROD
:
3892 gfc_conv_intrinsic_dprod (se
, expr
);
3895 case GFC_ISYM_FDATE
:
3896 gfc_conv_intrinsic_fdate (se
, expr
);
3900 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3903 case GFC_ISYM_IBCLR
:
3904 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
3907 case GFC_ISYM_IBITS
:
3908 gfc_conv_intrinsic_ibits (se
, expr
);
3911 case GFC_ISYM_IBSET
:
3912 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
3915 case GFC_ISYM_IACHAR
:
3916 case GFC_ISYM_ICHAR
:
3917 /* We assume ASCII character sequence. */
3918 gfc_conv_intrinsic_ichar (se
, expr
);
3921 case GFC_ISYM_IARGC
:
3922 gfc_conv_intrinsic_iargc (se
, expr
);
3926 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3929 case GFC_ISYM_INDEX
:
3930 gfc_conv_intrinsic_index (se
, expr
);
3934 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3937 case GFC_ISYM_LSHIFT
:
3938 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
3941 case GFC_ISYM_RSHIFT
:
3942 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
3945 case GFC_ISYM_ISHFT
:
3946 gfc_conv_intrinsic_ishft (se
, expr
);
3949 case GFC_ISYM_ISHFTC
:
3950 gfc_conv_intrinsic_ishftc (se
, expr
);
3953 case GFC_ISYM_LBOUND
:
3954 gfc_conv_intrinsic_bound (se
, expr
, 0);
3957 case GFC_ISYM_TRANSPOSE
:
3958 if (se
->ss
&& se
->ss
->useflags
)
3960 gfc_conv_tmp_array_ref (se
);
3961 gfc_advance_se_ss_chain (se
);
3964 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
3968 gfc_conv_intrinsic_len (se
, expr
);
3971 case GFC_ISYM_LEN_TRIM
:
3972 gfc_conv_intrinsic_len_trim (se
, expr
);
3976 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
3980 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
3984 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
3988 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
3992 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
3995 case GFC_ISYM_MAXLOC
:
3996 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
3999 case GFC_ISYM_MAXVAL
:
4000 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
4003 case GFC_ISYM_MERGE
:
4004 gfc_conv_intrinsic_merge (se
, expr
);
4008 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
4011 case GFC_ISYM_MINLOC
:
4012 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
4015 case GFC_ISYM_MINVAL
:
4016 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
4020 gfc_conv_intrinsic_not (se
, expr
);
4024 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4027 case GFC_ISYM_PRESENT
:
4028 gfc_conv_intrinsic_present (se
, expr
);
4031 case GFC_ISYM_PRODUCT
:
4032 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
4036 gfc_conv_intrinsic_sign (se
, expr
);
4040 gfc_conv_intrinsic_size (se
, expr
);
4043 case GFC_ISYM_SIZEOF
:
4044 gfc_conv_intrinsic_sizeof (se
, expr
);
4048 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
4051 case GFC_ISYM_TRANSFER
:
4054 if (se
->ss
->useflags
)
4056 /* Access the previously obtained result. */
4057 gfc_conv_tmp_array_ref (se
);
4058 gfc_advance_se_ss_chain (se
);
4062 gfc_conv_intrinsic_array_transfer (se
, expr
);
4065 gfc_conv_intrinsic_transfer (se
, expr
);
4068 case GFC_ISYM_TTYNAM
:
4069 gfc_conv_intrinsic_ttynam (se
, expr
);
4072 case GFC_ISYM_UBOUND
:
4073 gfc_conv_intrinsic_bound (se
, expr
, 1);
4077 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4081 gfc_conv_intrinsic_loc (se
, expr
);
4084 case GFC_ISYM_ACCESS
:
4085 case GFC_ISYM_CHDIR
:
4086 case GFC_ISYM_CHMOD
:
4087 case GFC_ISYM_ETIME
:
4089 case GFC_ISYM_FGETC
:
4092 case GFC_ISYM_FPUTC
:
4093 case GFC_ISYM_FSTAT
:
4094 case GFC_ISYM_FTELL
:
4095 case GFC_ISYM_GETCWD
:
4096 case GFC_ISYM_GETGID
:
4097 case GFC_ISYM_GETPID
:
4098 case GFC_ISYM_GETUID
:
4099 case GFC_ISYM_HOSTNM
:
4101 case GFC_ISYM_IERRNO
:
4102 case GFC_ISYM_IRAND
:
4103 case GFC_ISYM_ISATTY
:
4105 case GFC_ISYM_LSTAT
:
4106 case GFC_ISYM_MALLOC
:
4107 case GFC_ISYM_MATMUL
:
4108 case GFC_ISYM_MCLOCK
:
4109 case GFC_ISYM_MCLOCK8
:
4111 case GFC_ISYM_RENAME
:
4112 case GFC_ISYM_SECOND
:
4113 case GFC_ISYM_SECNDS
:
4114 case GFC_ISYM_SIGNAL
:
4116 case GFC_ISYM_SYMLNK
:
4117 case GFC_ISYM_SYSTEM
:
4119 case GFC_ISYM_TIME8
:
4120 case GFC_ISYM_UMASK
:
4121 case GFC_ISYM_UNLINK
:
4122 gfc_conv_intrinsic_funcall (se
, expr
);
4126 gfc_conv_intrinsic_lib_function (se
, expr
);
4132 /* This generates code to execute before entering the scalarization loop.
4133 Currently does nothing. */
4136 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
4138 switch (ss
->expr
->value
.function
.isym
->id
)
4140 case GFC_ISYM_UBOUND
:
4141 case GFC_ISYM_LBOUND
:
4150 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4151 inside the scalarization loop. */
4154 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
4158 /* The two argument version returns a scalar. */
4159 if (expr
->value
.function
.actual
->next
->expr
)
4162 newss
= gfc_get_ss ();
4163 newss
->type
= GFC_SS_INTRINSIC
;
4166 newss
->data
.info
.dimen
= 1;
4172 /* Walk an intrinsic array libcall. */
4175 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
4179 gcc_assert (expr
->rank
> 0);
4181 newss
= gfc_get_ss ();
4182 newss
->type
= GFC_SS_FUNCTION
;
4185 newss
->data
.info
.dimen
= expr
->rank
;
4191 /* Returns nonzero if the specified intrinsic function call maps directly to a
4192 an external library call. Should only be used for functions that return
4196 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
4198 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
4199 gcc_assert (expr
->rank
> 0);
4201 switch (expr
->value
.function
.isym
->id
)
4205 case GFC_ISYM_COUNT
:
4206 case GFC_ISYM_MATMUL
:
4207 case GFC_ISYM_MAXLOC
:
4208 case GFC_ISYM_MAXVAL
:
4209 case GFC_ISYM_MINLOC
:
4210 case GFC_ISYM_MINVAL
:
4211 case GFC_ISYM_PRODUCT
:
4213 case GFC_ISYM_SHAPE
:
4214 case GFC_ISYM_SPREAD
:
4215 case GFC_ISYM_TRANSPOSE
:
4216 /* Ignore absent optional parameters. */
4219 case GFC_ISYM_RESHAPE
:
4220 case GFC_ISYM_CSHIFT
:
4221 case GFC_ISYM_EOSHIFT
:
4223 case GFC_ISYM_UNPACK
:
4224 /* Pass absent optional parameters. */
4232 /* Walk an intrinsic function. */
4234 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
4235 gfc_intrinsic_sym
* isym
)
4239 if (isym
->elemental
)
4240 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
4242 if (expr
->rank
== 0)
4245 if (gfc_is_intrinsic_libcall (expr
))
4246 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4248 /* Special cases. */
4251 case GFC_ISYM_LBOUND
:
4252 case GFC_ISYM_UBOUND
:
4253 return gfc_walk_intrinsic_bound (ss
, expr
);
4255 case GFC_ISYM_TRANSFER
:
4256 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4259 /* This probably meant someone forgot to add an intrinsic to the above
4260 list(s) when they implemented it, or something's gone horribly wrong.
4262 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4263 expr
->value
.function
.name
);
4267 #include "gt-fortran-trans-intrinsic.h"