1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
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 LIB_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 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
115 /* Functions built into gcc itself. */
116 #include "mathbuiltins.def"
118 /* Functions in libgfortran. */
119 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
122 LIB_FUNCTION (NONE
, NULL
, false)
126 #undef DEFINE_MATH_BUILTIN
127 #undef DEFINE_MATH_BUILTIN_C
129 /* Structure for storing components of a floating number to be used by
130 elemental functions to manipulate reals. */
133 tree arg
; /* Variable tree to view convert to integer. */
134 tree expn
; /* Variable tree to save exponent. */
135 tree frac
; /* Variable tree to save fraction. */
136 tree smask
; /* Constant tree of sign's mask. */
137 tree emask
; /* Constant tree of exponent's mask. */
138 tree fmask
; /* Constant tree of fraction's mask. */
139 tree edigits
; /* Constant tree of the number of exponent bits. */
140 tree fdigits
; /* Constant tree of the number of fraction bits. */
141 tree f1
; /* Constant tree of the f1 defined in the real model. */
142 tree bias
; /* Constant tree of the bias of exponent in the memory. */
143 tree type
; /* Type tree of arg1. */
144 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
148 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
150 /* Evaluate the arguments to an intrinsic function. The value
151 of NARGS may be less than the actual number of arguments in EXPR
152 to allow optional "KIND" arguments that are not included in the
153 generated code to be ignored. */
156 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
157 tree
*argarray
, int nargs
)
159 gfc_actual_arglist
*actual
;
161 gfc_intrinsic_arg
*formal
;
165 formal
= expr
->value
.function
.isym
->formal
;
166 actual
= expr
->value
.function
.actual
;
168 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
169 actual
= actual
->next
,
170 formal
= formal
? formal
->next
: NULL
)
174 /* Skip omitted optional arguments. */
181 /* Evaluate the parameter. This will substitute scalarized
182 references automatically. */
183 gfc_init_se (&argse
, se
);
185 if (e
->ts
.type
== BT_CHARACTER
)
187 gfc_conv_expr (&argse
, e
);
188 gfc_conv_string_parameter (&argse
);
189 argarray
[curr_arg
++] = argse
.string_length
;
190 gcc_assert (curr_arg
< nargs
);
193 gfc_conv_expr_val (&argse
, e
);
195 /* If an optional argument is itself an optional dummy argument,
196 check its presence and substitute a null if absent. */
197 if (e
->expr_type
== EXPR_VARIABLE
198 && e
->symtree
->n
.sym
->attr
.optional
201 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
203 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
204 gfc_add_block_to_block (&se
->post
, &argse
.post
);
205 argarray
[curr_arg
] = argse
.expr
;
209 /* Count the number of actual arguments to the intrinsic function EXPR
210 including any "hidden" string length arguments. */
213 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
216 gfc_actual_arglist
*actual
;
218 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
223 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
233 /* Conversions between different types are output by the frontend as
234 intrinsic functions. We implement these directly with inline code. */
237 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
243 nargs
= gfc_intrinsic_argument_list_length (expr
);
244 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
246 /* Evaluate all the arguments passed. Whilst we're only interested in the
247 first one here, there are other parts of the front-end that assume this
248 and will trigger an ICE if it's not the case. */
249 type
= gfc_typenode_for_spec (&expr
->ts
);
250 gcc_assert (expr
->value
.function
.actual
->expr
);
251 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
253 /* Conversion between character kinds involves a call to a library
255 if (expr
->ts
.type
== BT_CHARACTER
)
257 tree fndecl
, var
, addr
, tmp
;
259 if (expr
->ts
.kind
== 1
260 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
261 fndecl
= gfor_fndecl_convert_char4_to_char1
;
262 else if (expr
->ts
.kind
== 4
263 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
264 fndecl
= gfor_fndecl_convert_char1_to_char4
;
268 /* Create the variable storing the converted value. */
269 type
= gfc_get_pchar_type (expr
->ts
.kind
);
270 var
= gfc_create_var (type
, "str");
271 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
273 /* Call the library function that will perform the conversion. */
274 gcc_assert (nargs
>= 2);
275 tmp
= build_call_expr (fndecl
, 3, addr
, args
[0], args
[1]);
276 gfc_add_expr_to_block (&se
->pre
, tmp
);
278 /* Free the temporary afterwards. */
279 tmp
= gfc_call_free (var
);
280 gfc_add_expr_to_block (&se
->post
, tmp
);
283 se
->string_length
= args
[0];
288 /* Conversion from complex to non-complex involves taking the real
289 component of the value. */
290 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
291 && expr
->ts
.type
!= BT_COMPLEX
)
295 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
296 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
299 se
->expr
= convert (type
, args
[0]);
302 /* This is needed because the gcc backend only implements
303 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
304 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
305 Similarly for CEILING. */
308 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
315 argtype
= TREE_TYPE (arg
);
316 arg
= gfc_evaluate_now (arg
, pblock
);
318 intval
= convert (type
, arg
);
319 intval
= gfc_evaluate_now (intval
, pblock
);
321 tmp
= convert (argtype
, intval
);
322 cond
= fold_build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
324 tmp
= fold_build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
325 build_int_cst (type
, 1));
326 tmp
= fold_build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
331 /* Round to nearest integer, away from zero. */
334 build_round_expr (tree arg
, tree restype
)
339 int argprec
, resprec
;
341 argtype
= TREE_TYPE (arg
);
342 argprec
= TYPE_PRECISION (argtype
);
343 resprec
= TYPE_PRECISION (restype
);
345 /* Depending on the type of the result, choose the long int intrinsic
346 (lround family) or long long intrinsic (llround). We might also
347 need to convert the result afterwards. */
348 if (resprec
<= LONG_TYPE_SIZE
)
350 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
355 /* Now, depending on the argument type, we choose between intrinsics. */
356 if (argprec
== TYPE_PRECISION (float_type_node
))
357 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDF
: BUILT_IN_LROUNDF
];
358 else if (argprec
== TYPE_PRECISION (double_type_node
))
359 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUND
: BUILT_IN_LROUND
];
360 else if (argprec
== TYPE_PRECISION (long_double_type_node
))
361 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDL
: BUILT_IN_LROUNDL
];
365 return fold_convert (restype
, build_call_expr (fn
, 1, arg
));
369 /* Convert a real to an integer using a specific rounding mode.
370 Ideally we would just build the corresponding GENERIC node,
371 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
374 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
375 enum rounding_mode op
)
380 return build_fixbound_expr (pblock
, arg
, type
, 0);
384 return build_fixbound_expr (pblock
, arg
, type
, 1);
388 return build_round_expr (arg
, type
);
392 return fold_build1 (FIX_TRUNC_EXPR
, type
, arg
);
401 /* Round a real value using the specified rounding mode.
402 We use a temporary integer of that same kind size as the result.
403 Values larger than those that can be represented by this kind are
404 unchanged, as they will not be accurate enough to represent the
406 huge = HUGE (KIND (a))
407 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
411 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
422 kind
= expr
->ts
.kind
;
423 nargs
= gfc_intrinsic_argument_list_length (expr
);
426 /* We have builtin functions for some cases. */
469 /* Evaluate the argument. */
470 gcc_assert (expr
->value
.function
.actual
->expr
);
471 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
473 /* Use a builtin function if one exists. */
474 if (n
!= END_BUILTINS
)
476 tmp
= built_in_decls
[n
];
477 se
->expr
= build_call_expr (tmp
, 1, arg
[0]);
481 /* This code is probably redundant, but we'll keep it lying around just
483 type
= gfc_typenode_for_spec (&expr
->ts
);
484 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
486 /* Test if the value is too large to handle sensibly. */
487 gfc_set_model_kind (kind
);
489 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
490 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
491 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
492 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, arg
[0], tmp
);
494 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
495 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
496 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
[0], tmp
);
497 cond
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
498 itype
= gfc_get_int_type (kind
);
500 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
501 tmp
= convert (type
, tmp
);
502 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
, tmp
, arg
[0]);
507 /* Convert to an integer using the specified rounding mode. */
510 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
516 nargs
= gfc_intrinsic_argument_list_length (expr
);
517 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
519 /* Evaluate the argument, we process all arguments even though we only
520 use the first one for code generation purposes. */
521 type
= gfc_typenode_for_spec (&expr
->ts
);
522 gcc_assert (expr
->value
.function
.actual
->expr
);
523 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
525 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
527 /* Conversion to a different integer kind. */
528 se
->expr
= convert (type
, args
[0]);
532 /* Conversion from complex to non-complex involves taking the real
533 component of the value. */
534 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
535 && expr
->ts
.type
!= BT_COMPLEX
)
539 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
540 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
543 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
548 /* Get the imaginary component of a value. */
551 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
555 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
556 se
->expr
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
560 /* Get the complex conjugate of a value. */
563 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
567 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
568 se
->expr
= fold_build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
572 /* Initialize function decls for library functions. The external functions
573 are created as required. Builtin functions are added here. */
576 gfc_build_intrinsic_lib_fndecls (void)
578 gfc_intrinsic_map_t
*m
;
580 /* Add GCC builtin functions. */
581 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
583 if (m
->code_r4
!= END_BUILTINS
)
584 m
->real4_decl
= built_in_decls
[m
->code_r4
];
585 if (m
->code_r8
!= END_BUILTINS
)
586 m
->real8_decl
= built_in_decls
[m
->code_r8
];
587 if (m
->code_r10
!= END_BUILTINS
)
588 m
->real10_decl
= built_in_decls
[m
->code_r10
];
589 if (m
->code_r16
!= END_BUILTINS
)
590 m
->real16_decl
= built_in_decls
[m
->code_r16
];
591 if (m
->code_c4
!= END_BUILTINS
)
592 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
593 if (m
->code_c8
!= END_BUILTINS
)
594 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
595 if (m
->code_c10
!= END_BUILTINS
)
596 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
597 if (m
->code_c16
!= END_BUILTINS
)
598 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
603 /* Create a fndecl for a simple intrinsic library function. */
606 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
611 gfc_actual_arglist
*actual
;
614 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
617 if (ts
->type
== BT_REAL
)
622 pdecl
= &m
->real4_decl
;
625 pdecl
= &m
->real8_decl
;
628 pdecl
= &m
->real10_decl
;
631 pdecl
= &m
->real16_decl
;
637 else if (ts
->type
== BT_COMPLEX
)
639 gcc_assert (m
->complex_available
);
644 pdecl
= &m
->complex4_decl
;
647 pdecl
= &m
->complex8_decl
;
650 pdecl
= &m
->complex10_decl
;
653 pdecl
= &m
->complex16_decl
;
668 snprintf (name
, sizeof (name
), "%s%s%s",
669 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
670 else if (ts
->kind
== 8)
671 snprintf (name
, sizeof (name
), "%s%s",
672 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
675 gcc_assert (ts
->kind
== 10 || ts
->kind
== 16);
676 snprintf (name
, sizeof (name
), "%s%s%s",
677 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
682 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
683 ts
->type
== BT_COMPLEX
? 'c' : 'r',
687 argtypes
= NULL_TREE
;
688 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
690 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
691 argtypes
= gfc_chainon_list (argtypes
, type
);
693 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
694 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
695 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
697 /* Mark the decl as external. */
698 DECL_EXTERNAL (fndecl
) = 1;
699 TREE_PUBLIC (fndecl
) = 1;
701 /* Mark it __attribute__((const)), if possible. */
702 TREE_READONLY (fndecl
) = m
->is_constant
;
704 rest_of_decl_compilation (fndecl
, 1, 0);
711 /* Convert an intrinsic function into an external or builtin call. */
714 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
716 gfc_intrinsic_map_t
*m
;
720 unsigned int num_args
;
723 id
= expr
->value
.function
.isym
->id
;
724 /* Find the entry for this function. */
725 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
731 if (m
->id
== GFC_ISYM_NONE
)
733 internal_error ("Intrinsic function %s(%d) not recognized",
734 expr
->value
.function
.name
, id
);
737 /* Get the decl and generate the call. */
738 num_args
= gfc_intrinsic_argument_list_length (expr
);
739 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
741 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
742 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
743 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
745 fndecl
= build_addr (fndecl
, current_function_decl
);
746 se
->expr
= build_call_array (rettype
, fndecl
, num_args
, args
);
749 /* The EXPONENT(s) intrinsic function is translated into
756 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
758 tree arg
, type
, res
, tmp
;
761 switch (expr
->value
.function
.actual
->expr
->ts
.kind
)
764 frexp
= BUILT_IN_FREXPF
;
767 frexp
= BUILT_IN_FREXP
;
771 frexp
= BUILT_IN_FREXPL
;
777 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
779 res
= gfc_create_var (integer_type_node
, NULL
);
780 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
781 build_fold_addr_expr (res
));
782 gfc_add_expr_to_block (&se
->pre
, tmp
);
784 type
= gfc_typenode_for_spec (&expr
->ts
);
785 se
->expr
= fold_convert (type
, res
);
788 /* Evaluate a single upper or lower bound. */
789 /* TODO: bound intrinsic generates way too much unnecessary code. */
792 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
794 gfc_actual_arglist
*arg
;
795 gfc_actual_arglist
*arg2
;
800 tree cond
, cond1
, cond2
, cond3
, cond4
, size
;
808 arg
= expr
->value
.function
.actual
;
813 /* Create an implicit second parameter from the loop variable. */
814 gcc_assert (!arg2
->expr
);
815 gcc_assert (se
->loop
->dimen
== 1);
816 gcc_assert (se
->ss
->expr
== expr
);
817 gfc_advance_se_ss_chain (se
);
818 bound
= se
->loop
->loopvar
[0];
819 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
824 /* use the passed argument. */
825 gcc_assert (arg
->next
->expr
);
826 gfc_init_se (&argse
, NULL
);
827 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
828 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
830 /* Convert from one based to zero based. */
831 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
835 /* TODO: don't re-evaluate the descriptor on each iteration. */
836 /* Get a descriptor for the first parameter. */
837 ss
= gfc_walk_expr (arg
->expr
);
838 gcc_assert (ss
!= gfc_ss_terminator
);
839 gfc_init_se (&argse
, NULL
);
840 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
841 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
842 gfc_add_block_to_block (&se
->post
, &argse
.post
);
846 if (INTEGER_CST_P (bound
))
850 hi
= TREE_INT_CST_HIGH (bound
);
851 low
= TREE_INT_CST_LOW (bound
);
852 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
853 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
854 "dimension index", upper
? "UBOUND" : "LBOUND",
859 if (flag_bounds_check
)
861 bound
= gfc_evaluate_now (bound
, &se
->pre
);
862 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
863 bound
, build_int_cst (TREE_TYPE (bound
), 0));
864 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
865 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
866 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
867 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
872 ubound
= gfc_conv_descriptor_ubound (desc
, bound
);
873 lbound
= gfc_conv_descriptor_lbound (desc
, bound
);
875 /* Follow any component references. */
876 if (arg
->expr
->expr_type
== EXPR_VARIABLE
877 || arg
->expr
->expr_type
== EXPR_CONSTANT
)
879 as
= arg
->expr
->symtree
->n
.sym
->as
;
880 for (ref
= arg
->expr
->ref
; ref
; ref
= ref
->next
)
885 as
= ref
->u
.c
.component
->as
;
893 switch (ref
->u
.ar
.type
)
912 /* 13.14.53: Result value for LBOUND
914 Case (i): For an array section or for an array expression other than a
915 whole array or array structure component, LBOUND(ARRAY, DIM)
916 has the value 1. For a whole array or array structure
917 component, LBOUND(ARRAY, DIM) has the value:
918 (a) equal to the lower bound for subscript DIM of ARRAY if
919 dimension DIM of ARRAY does not have extent zero
920 or if ARRAY is an assumed-size array of rank DIM,
923 13.14.113: Result value for UBOUND
925 Case (i): For an array section or for an array expression other than a
926 whole array or array structure component, UBOUND(ARRAY, DIM)
927 has the value equal to the number of elements in the given
928 dimension; otherwise, it has a value equal to the upper bound
929 for subscript DIM of ARRAY if dimension DIM of ARRAY does
930 not have size zero and has value zero if dimension DIM has
935 tree stride
= gfc_conv_descriptor_stride (desc
, bound
);
937 cond1
= fold_build2 (GE_EXPR
, boolean_type_node
, ubound
, lbound
);
938 cond2
= fold_build2 (LE_EXPR
, boolean_type_node
, ubound
, lbound
);
940 cond3
= fold_build2 (GE_EXPR
, boolean_type_node
, stride
,
941 gfc_index_zero_node
);
942 cond3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond3
, cond1
);
944 cond4
= fold_build2 (LT_EXPR
, boolean_type_node
, stride
,
945 gfc_index_zero_node
);
946 cond4
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond4
, cond2
);
950 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
952 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
953 ubound
, gfc_index_zero_node
);
957 if (as
->type
== AS_ASSUMED_SIZE
)
958 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, bound
,
959 build_int_cst (TREE_TYPE (bound
),
960 arg
->expr
->rank
- 1));
962 cond
= boolean_false_node
;
964 cond1
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
965 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond1
);
967 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
968 lbound
, gfc_index_one_node
);
975 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
976 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
978 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
979 gfc_index_zero_node
);
982 se
->expr
= gfc_index_one_node
;
985 type
= gfc_typenode_for_spec (&expr
->ts
);
986 se
->expr
= convert (type
, se
->expr
);
991 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
996 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
998 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1002 se
->expr
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg
), arg
);
1006 switch (expr
->ts
.kind
)
1021 se
->expr
= build_call_expr (built_in_decls
[n
], 1, arg
);
1030 /* Create a complex value from one or two real components. */
1033 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1039 unsigned int num_args
;
1041 num_args
= gfc_intrinsic_argument_list_length (expr
);
1042 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1044 type
= gfc_typenode_for_spec (&expr
->ts
);
1045 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1046 real
= convert (TREE_TYPE (type
), args
[0]);
1048 imag
= convert (TREE_TYPE (type
), args
[1]);
1049 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1051 imag
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (args
[0])),
1053 imag
= convert (TREE_TYPE (type
), imag
);
1056 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1058 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
1061 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1062 MODULO(A, P) = A - FLOOR (A / P) * P */
1063 /* TODO: MOD(x, 0) */
1066 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1077 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1079 switch (expr
->ts
.type
)
1082 /* Integer case is easy, we've got a builtin op. */
1083 type
= TREE_TYPE (args
[0]);
1086 se
->expr
= fold_build2 (FLOOR_MOD_EXPR
, type
, args
[0], args
[1]);
1088 se
->expr
= fold_build2 (TRUNC_MOD_EXPR
, type
, args
[0], args
[1]);
1093 /* Check if we have a builtin fmod. */
1094 switch (expr
->ts
.kind
)
1113 /* Use it if it exists. */
1114 if (n
!= END_BUILTINS
)
1116 tmp
= build_addr (built_in_decls
[n
], current_function_decl
);
1117 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls
[n
])),
1123 type
= TREE_TYPE (args
[0]);
1125 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1126 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1129 modulo = arg - floor (arg/arg2) * arg2, so
1130 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1132 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1133 thereby avoiding another division and retaining the accuracy
1134 of the builtin function. */
1135 if (n
!= END_BUILTINS
&& modulo
)
1137 tree zero
= gfc_build_const (type
, integer_zero_node
);
1138 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1139 test
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[0], zero
);
1140 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[1], zero
);
1141 test2
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
1142 test
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, zero
);
1143 test
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1144 test
= gfc_evaluate_now (test
, &se
->pre
);
1145 se
->expr
= fold_build3 (COND_EXPR
, type
, test
,
1146 fold_build2 (PLUS_EXPR
, type
, tmp
, args
[1]),
1151 /* If we do not have a built_in fmod, the calculation is going to
1152 have to be done longhand. */
1153 tmp
= fold_build2 (RDIV_EXPR
, type
, args
[0], args
[1]);
1155 /* Test if the value is too large to handle sensibly. */
1156 gfc_set_model_kind (expr
->ts
.kind
);
1158 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1159 ikind
= expr
->ts
.kind
;
1162 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1163 ikind
= gfc_max_integer_kind
;
1165 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1166 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1167 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
1169 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1170 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1171 test
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
1172 test2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1174 itype
= gfc_get_int_type (ikind
);
1176 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1178 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1179 tmp
= convert (type
, tmp
);
1180 tmp
= fold_build3 (COND_EXPR
, type
, test2
, tmp
, args
[0]);
1181 tmp
= fold_build2 (MULT_EXPR
, type
, tmp
, args
[1]);
1182 se
->expr
= fold_build2 (MINUS_EXPR
, type
, args
[0], tmp
);
1191 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1194 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1202 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1203 type
= TREE_TYPE (args
[0]);
1205 val
= fold_build2 (MINUS_EXPR
, type
, args
[0], args
[1]);
1206 val
= gfc_evaluate_now (val
, &se
->pre
);
1208 zero
= gfc_build_const (type
, integer_zero_node
);
1209 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
1210 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, zero
, val
);
1214 /* SIGN(A, B) is absolute value of A times sign of B.
1215 The real value versions use library functions to ensure the correct
1216 handling of negative zero. Integer case implemented as:
1217 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1221 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1227 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1228 if (expr
->ts
.type
== BT_REAL
)
1230 switch (expr
->ts
.kind
)
1233 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
1236 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
1240 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
1245 se
->expr
= build_call_expr (tmp
, 2, args
[0], args
[1]);
1249 /* Having excluded floating point types, we know we are now dealing
1250 with signed integer types. */
1251 type
= TREE_TYPE (args
[0]);
1253 /* Args[0] is used multiple times below. */
1254 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1256 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1257 the signs of A and B are the same, and of all ones if they differ. */
1258 tmp
= fold_build2 (BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1259 tmp
= fold_build2 (RSHIFT_EXPR
, type
, tmp
,
1260 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1261 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1263 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1264 is all ones (i.e. -1). */
1265 se
->expr
= fold_build2 (BIT_XOR_EXPR
, type
,
1266 fold_build2 (PLUS_EXPR
, type
, args
[0], tmp
),
1271 /* Test for the presence of an optional argument. */
1274 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1278 arg
= expr
->value
.function
.actual
->expr
;
1279 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1280 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1281 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1285 /* Calculate the double precision product of two single precision values. */
1288 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1293 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1295 /* Convert the args to double precision before multiplying. */
1296 type
= gfc_typenode_for_spec (&expr
->ts
);
1297 args
[0] = convert (type
, args
[0]);
1298 args
[1] = convert (type
, args
[1]);
1299 se
->expr
= fold_build2 (MULT_EXPR
, type
, args
[0], args
[1]);
1303 /* Return a length one character string containing an ascii character. */
1306 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1311 unsigned int num_args
;
1313 num_args
= gfc_intrinsic_argument_list_length (expr
);
1314 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
1316 type
= gfc_get_char_type (expr
->ts
.kind
);
1317 var
= gfc_create_var (type
, "char");
1319 arg
[0] = fold_build1 (NOP_EXPR
, type
, arg
[0]);
1320 gfc_add_modify (&se
->pre
, var
, arg
[0]);
1321 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1322 se
->string_length
= integer_one_node
;
1327 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1335 unsigned int num_args
;
1337 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1338 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1340 var
= gfc_create_var (pchar_type_node
, "pstr");
1341 len
= gfc_create_var (gfc_get_int_type (8), "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_ctime
, current_function_decl
);
1348 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1349 fndecl
, num_args
, args
);
1350 gfc_add_expr_to_block (&se
->pre
, tmp
);
1352 /* Free the temporary afterwards, if necessary. */
1353 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1354 len
, 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
;
1365 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1373 unsigned int num_args
;
1375 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1376 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1378 var
= gfc_create_var (pchar_type_node
, "pstr");
1379 len
= gfc_create_var (gfc_get_int_type (4), "len");
1381 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1382 args
[0] = build_fold_addr_expr (var
);
1383 args
[1] = build_fold_addr_expr (len
);
1385 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1386 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1387 fndecl
, num_args
, args
);
1388 gfc_add_expr_to_block (&se
->pre
, tmp
);
1390 /* Free the temporary afterwards, if necessary. */
1391 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1392 len
, build_int_cst (TREE_TYPE (len
), 0));
1393 tmp
= gfc_call_free (var
);
1394 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1395 gfc_add_expr_to_block (&se
->post
, tmp
);
1398 se
->string_length
= len
;
1402 /* Return a character string containing the tty name. */
1405 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1413 unsigned int num_args
;
1415 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1416 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
1418 var
= gfc_create_var (pchar_type_node
, "pstr");
1419 len
= gfc_create_var (gfc_get_int_type (4), "len");
1421 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1422 args
[0] = build_fold_addr_expr (var
);
1423 args
[1] = build_fold_addr_expr (len
);
1425 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1426 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1427 fndecl
, num_args
, args
);
1428 gfc_add_expr_to_block (&se
->pre
, tmp
);
1430 /* Free the temporary afterwards, if necessary. */
1431 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1432 len
, build_int_cst (TREE_TYPE (len
), 0));
1433 tmp
= gfc_call_free (var
);
1434 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1435 gfc_add_expr_to_block (&se
->post
, tmp
);
1438 se
->string_length
= len
;
1442 /* Get the minimum/maximum value of all the parameters.
1443 minmax (a1, a2, a3, ...)
1446 if (a2 .op. mvar || isnan(mvar))
1448 if (a3 .op. mvar || isnan(mvar))
1455 /* TODO: Mismatching types can occur when specific names are used.
1456 These should be handled during resolution. */
1458 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1466 gfc_actual_arglist
*argexpr
;
1467 unsigned int i
, nargs
;
1469 nargs
= gfc_intrinsic_argument_list_length (expr
);
1470 args
= (tree
*) alloca (sizeof (tree
) * nargs
);
1472 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1473 type
= gfc_typenode_for_spec (&expr
->ts
);
1475 argexpr
= expr
->value
.function
.actual
;
1476 if (TREE_TYPE (args
[0]) != type
)
1477 args
[0] = convert (type
, args
[0]);
1478 /* Only evaluate the argument once. */
1479 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
1480 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1482 mvar
= gfc_create_var (type
, "M");
1483 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
1484 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1490 /* Handle absent optional arguments by ignoring the comparison. */
1491 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1492 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1493 && TREE_CODE (val
) == INDIRECT_REF
)
1495 (NE_EXPR
, boolean_type_node
, TREE_OPERAND (val
, 0),
1496 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1501 /* Only evaluate the argument once. */
1502 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1503 val
= gfc_evaluate_now (val
, &se
->pre
);
1506 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1508 tmp
= fold_build2 (op
, boolean_type_node
, convert (type
, val
), mvar
);
1510 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1511 __builtin_isnan might be made dependent on that module being loaded,
1512 to help performance of programs that don't rely on IEEE semantics. */
1513 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
1515 isnan
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, mvar
);
1516 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
,
1517 fold_convert (boolean_type_node
, isnan
));
1519 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, build_empty_stmt ());
1521 if (cond
!= NULL_TREE
)
1522 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1524 gfc_add_expr_to_block (&se
->pre
, tmp
);
1525 argexpr
= argexpr
->next
;
1531 /* Generate library calls for MIN and MAX intrinsics for character
1534 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
1537 tree var
, len
, fndecl
, tmp
, cond
, function
;
1540 nargs
= gfc_intrinsic_argument_list_length (expr
);
1541 args
= (tree
*) alloca (sizeof (tree
) * (nargs
+ 4));
1542 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
1544 /* Create the result variables. */
1545 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1546 args
[0] = build_fold_addr_expr (len
);
1547 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
1548 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
1549 args
[2] = build_int_cst (NULL_TREE
, op
);
1550 args
[3] = build_int_cst (NULL_TREE
, nargs
/ 2);
1552 if (expr
->ts
.kind
== 1)
1553 function
= gfor_fndecl_string_minmax
;
1554 else if (expr
->ts
.kind
== 4)
1555 function
= gfor_fndecl_string_minmax_char4
;
1559 /* Make the function call. */
1560 fndecl
= build_addr (function
, current_function_decl
);
1561 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
1563 gfc_add_expr_to_block (&se
->pre
, tmp
);
1565 /* Free the temporary afterwards, if necessary. */
1566 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1567 len
, build_int_cst (TREE_TYPE (len
), 0));
1568 tmp
= gfc_call_free (var
);
1569 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1570 gfc_add_expr_to_block (&se
->post
, tmp
);
1573 se
->string_length
= len
;
1577 /* Create a symbol node for this intrinsic. The symbol from the frontend
1578 has the generic name. */
1581 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1585 /* TODO: Add symbols for intrinsic function to the global namespace. */
1586 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1587 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1590 sym
->attr
.external
= 1;
1591 sym
->attr
.function
= 1;
1592 sym
->attr
.always_explicit
= 1;
1593 sym
->attr
.proc
= PROC_INTRINSIC
;
1594 sym
->attr
.flavor
= FL_PROCEDURE
;
1598 sym
->attr
.dimension
= 1;
1599 sym
->as
= gfc_get_array_spec ();
1600 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1601 sym
->as
->rank
= expr
->rank
;
1604 /* TODO: proper argument lists for external intrinsics. */
1608 /* Generate a call to an external intrinsic function. */
1610 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1615 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1618 gcc_assert (expr
->rank
> 0);
1620 gcc_assert (expr
->rank
== 0);
1622 sym
= gfc_get_symbol_for_expr (expr
);
1624 /* Calls to libgfortran_matmul need to be appended special arguments,
1625 to be able to call the BLAS ?gemm functions if required and possible. */
1626 append_args
= NULL_TREE
;
1627 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1628 && sym
->ts
.type
!= BT_LOGICAL
)
1630 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1632 if (gfc_option
.flag_external_blas
1633 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1634 && (sym
->ts
.kind
== gfc_default_real_kind
1635 || sym
->ts
.kind
== gfc_default_double_kind
))
1639 if (sym
->ts
.type
== BT_REAL
)
1641 if (sym
->ts
.kind
== gfc_default_real_kind
)
1642 gemm_fndecl
= gfor_fndecl_sgemm
;
1644 gemm_fndecl
= gfor_fndecl_dgemm
;
1648 if (sym
->ts
.kind
== gfc_default_real_kind
)
1649 gemm_fndecl
= gfor_fndecl_cgemm
;
1651 gemm_fndecl
= gfor_fndecl_zgemm
;
1654 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 1));
1655 append_args
= gfc_chainon_list
1656 (append_args
, build_int_cst
1657 (cint
, gfc_option
.blas_matmul_limit
));
1658 append_args
= gfc_chainon_list (append_args
,
1659 gfc_build_addr_expr (NULL_TREE
,
1664 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 0));
1665 append_args
= gfc_chainon_list (append_args
, build_int_cst (cint
, 0));
1666 append_args
= gfc_chainon_list (append_args
, null_pointer_node
);
1670 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
1674 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1694 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1703 gfc_actual_arglist
*actual
;
1710 gfc_conv_intrinsic_funcall (se
, expr
);
1714 actual
= expr
->value
.function
.actual
;
1715 type
= gfc_typenode_for_spec (&expr
->ts
);
1716 /* Initialize the result. */
1717 resvar
= gfc_create_var (type
, "test");
1719 tmp
= convert (type
, boolean_true_node
);
1721 tmp
= convert (type
, boolean_false_node
);
1722 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1724 /* Walk the arguments. */
1725 arrayss
= gfc_walk_expr (actual
->expr
);
1726 gcc_assert (arrayss
!= gfc_ss_terminator
);
1728 /* Initialize the scalarizer. */
1729 gfc_init_loopinfo (&loop
);
1730 exit_label
= gfc_build_label_decl (NULL_TREE
);
1731 TREE_USED (exit_label
) = 1;
1732 gfc_add_ss_to_loop (&loop
, arrayss
);
1734 /* Initialize the loop. */
1735 gfc_conv_ss_startstride (&loop
);
1736 gfc_conv_loop_setup (&loop
, &expr
->where
);
1738 gfc_mark_ss_chain_used (arrayss
, 1);
1739 /* Generate the loop body. */
1740 gfc_start_scalarized_body (&loop
, &body
);
1742 /* If the condition matches then set the return value. */
1743 gfc_start_block (&block
);
1745 tmp
= convert (type
, boolean_false_node
);
1747 tmp
= convert (type
, boolean_true_node
);
1748 gfc_add_modify (&block
, resvar
, tmp
);
1750 /* And break out of the loop. */
1751 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1752 gfc_add_expr_to_block (&block
, tmp
);
1754 found
= gfc_finish_block (&block
);
1756 /* Check this element. */
1757 gfc_init_se (&arrayse
, NULL
);
1758 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1759 arrayse
.ss
= arrayss
;
1760 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1762 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1763 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1764 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1765 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1766 gfc_add_expr_to_block (&body
, tmp
);
1767 gfc_add_block_to_block (&body
, &arrayse
.post
);
1769 gfc_trans_scalarizing_loops (&loop
, &body
);
1771 /* Add the exit label. */
1772 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1773 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1775 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1776 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1777 gfc_cleanup_loop (&loop
);
1782 /* COUNT(A) = Number of true elements in A. */
1784 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1791 gfc_actual_arglist
*actual
;
1797 gfc_conv_intrinsic_funcall (se
, expr
);
1801 actual
= expr
->value
.function
.actual
;
1803 type
= gfc_typenode_for_spec (&expr
->ts
);
1804 /* Initialize the result. */
1805 resvar
= gfc_create_var (type
, "count");
1806 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
1808 /* Walk the arguments. */
1809 arrayss
= gfc_walk_expr (actual
->expr
);
1810 gcc_assert (arrayss
!= gfc_ss_terminator
);
1812 /* Initialize the scalarizer. */
1813 gfc_init_loopinfo (&loop
);
1814 gfc_add_ss_to_loop (&loop
, arrayss
);
1816 /* Initialize the loop. */
1817 gfc_conv_ss_startstride (&loop
);
1818 gfc_conv_loop_setup (&loop
, &expr
->where
);
1820 gfc_mark_ss_chain_used (arrayss
, 1);
1821 /* Generate the loop body. */
1822 gfc_start_scalarized_body (&loop
, &body
);
1824 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (resvar
),
1825 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
1826 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1828 gfc_init_se (&arrayse
, NULL
);
1829 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1830 arrayse
.ss
= arrayss
;
1831 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1832 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1834 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1835 gfc_add_expr_to_block (&body
, tmp
);
1836 gfc_add_block_to_block (&body
, &arrayse
.post
);
1838 gfc_trans_scalarizing_loops (&loop
, &body
);
1840 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1841 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1842 gfc_cleanup_loop (&loop
);
1847 /* Inline implementation of the sum and product intrinsics. */
1849 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1857 gfc_actual_arglist
*actual
;
1862 gfc_expr
*arrayexpr
;
1867 gfc_conv_intrinsic_funcall (se
, expr
);
1871 type
= gfc_typenode_for_spec (&expr
->ts
);
1872 /* Initialize the result. */
1873 resvar
= gfc_create_var (type
, "val");
1874 if (op
== PLUS_EXPR
)
1875 tmp
= gfc_build_const (type
, integer_zero_node
);
1877 tmp
= gfc_build_const (type
, integer_one_node
);
1879 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1881 /* Walk the arguments. */
1882 actual
= expr
->value
.function
.actual
;
1883 arrayexpr
= actual
->expr
;
1884 arrayss
= gfc_walk_expr (arrayexpr
);
1885 gcc_assert (arrayss
!= gfc_ss_terminator
);
1887 actual
= actual
->next
->next
;
1888 gcc_assert (actual
);
1889 maskexpr
= actual
->expr
;
1890 if (maskexpr
&& maskexpr
->rank
!= 0)
1892 maskss
= gfc_walk_expr (maskexpr
);
1893 gcc_assert (maskss
!= gfc_ss_terminator
);
1898 /* Initialize the scalarizer. */
1899 gfc_init_loopinfo (&loop
);
1900 gfc_add_ss_to_loop (&loop
, arrayss
);
1902 gfc_add_ss_to_loop (&loop
, maskss
);
1904 /* Initialize the loop. */
1905 gfc_conv_ss_startstride (&loop
);
1906 gfc_conv_loop_setup (&loop
, &expr
->where
);
1908 gfc_mark_ss_chain_used (arrayss
, 1);
1910 gfc_mark_ss_chain_used (maskss
, 1);
1911 /* Generate the loop body. */
1912 gfc_start_scalarized_body (&loop
, &body
);
1914 /* If we have a mask, only add this element if the mask is set. */
1917 gfc_init_se (&maskse
, NULL
);
1918 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1920 gfc_conv_expr_val (&maskse
, maskexpr
);
1921 gfc_add_block_to_block (&body
, &maskse
.pre
);
1923 gfc_start_block (&block
);
1926 gfc_init_block (&block
);
1928 /* Do the actual summation/product. */
1929 gfc_init_se (&arrayse
, NULL
);
1930 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1931 arrayse
.ss
= arrayss
;
1932 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1933 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1935 tmp
= fold_build2 (op
, type
, resvar
, arrayse
.expr
);
1936 gfc_add_modify (&block
, resvar
, tmp
);
1937 gfc_add_block_to_block (&block
, &arrayse
.post
);
1941 /* We enclose the above in if (mask) {...} . */
1942 tmp
= gfc_finish_block (&block
);
1944 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1947 tmp
= gfc_finish_block (&block
);
1948 gfc_add_expr_to_block (&body
, tmp
);
1950 gfc_trans_scalarizing_loops (&loop
, &body
);
1952 /* For a scalar mask, enclose the loop in an if statement. */
1953 if (maskexpr
&& maskss
== NULL
)
1955 gfc_init_se (&maskse
, NULL
);
1956 gfc_conv_expr_val (&maskse
, maskexpr
);
1957 gfc_init_block (&block
);
1958 gfc_add_block_to_block (&block
, &loop
.pre
);
1959 gfc_add_block_to_block (&block
, &loop
.post
);
1960 tmp
= gfc_finish_block (&block
);
1962 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1963 gfc_add_expr_to_block (&block
, tmp
);
1964 gfc_add_block_to_block (&se
->pre
, &block
);
1968 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1969 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1972 gfc_cleanup_loop (&loop
);
1978 /* Inline implementation of the dot_product intrinsic. This function
1979 is based on gfc_conv_intrinsic_arith (the previous function). */
1981 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1989 gfc_actual_arglist
*actual
;
1990 gfc_ss
*arrayss1
, *arrayss2
;
1991 gfc_se arrayse1
, arrayse2
;
1992 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1994 type
= gfc_typenode_for_spec (&expr
->ts
);
1996 /* Initialize the result. */
1997 resvar
= gfc_create_var (type
, "val");
1998 if (expr
->ts
.type
== BT_LOGICAL
)
1999 tmp
= build_int_cst (type
, 0);
2001 tmp
= gfc_build_const (type
, integer_zero_node
);
2003 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2005 /* Walk argument #1. */
2006 actual
= expr
->value
.function
.actual
;
2007 arrayexpr1
= actual
->expr
;
2008 arrayss1
= gfc_walk_expr (arrayexpr1
);
2009 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2011 /* Walk argument #2. */
2012 actual
= actual
->next
;
2013 arrayexpr2
= actual
->expr
;
2014 arrayss2
= gfc_walk_expr (arrayexpr2
);
2015 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2017 /* Initialize the scalarizer. */
2018 gfc_init_loopinfo (&loop
);
2019 gfc_add_ss_to_loop (&loop
, arrayss1
);
2020 gfc_add_ss_to_loop (&loop
, arrayss2
);
2022 /* Initialize the loop. */
2023 gfc_conv_ss_startstride (&loop
);
2024 gfc_conv_loop_setup (&loop
, &expr
->where
);
2026 gfc_mark_ss_chain_used (arrayss1
, 1);
2027 gfc_mark_ss_chain_used (arrayss2
, 1);
2029 /* Generate the loop body. */
2030 gfc_start_scalarized_body (&loop
, &body
);
2031 gfc_init_block (&block
);
2033 /* Make the tree expression for [conjg(]array1[)]. */
2034 gfc_init_se (&arrayse1
, NULL
);
2035 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2036 arrayse1
.ss
= arrayss1
;
2037 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2038 if (expr
->ts
.type
== BT_COMPLEX
)
2039 arrayse1
.expr
= fold_build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
2040 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2042 /* Make the tree expression for array2. */
2043 gfc_init_se (&arrayse2
, NULL
);
2044 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2045 arrayse2
.ss
= arrayss2
;
2046 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2047 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2049 /* Do the actual product and sum. */
2050 if (expr
->ts
.type
== BT_LOGICAL
)
2052 tmp
= fold_build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2053 tmp
= fold_build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2057 tmp
= fold_build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2058 tmp
= fold_build2 (PLUS_EXPR
, type
, resvar
, tmp
);
2060 gfc_add_modify (&block
, resvar
, tmp
);
2062 /* Finish up the loop block and the loop. */
2063 tmp
= gfc_finish_block (&block
);
2064 gfc_add_expr_to_block (&body
, tmp
);
2066 gfc_trans_scalarizing_loops (&loop
, &body
);
2067 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2068 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2069 gfc_cleanup_loop (&loop
);
2076 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
2080 stmtblock_t ifblock
;
2081 stmtblock_t elseblock
;
2089 gfc_actual_arglist
*actual
;
2094 gfc_expr
*arrayexpr
;
2101 gfc_conv_intrinsic_funcall (se
, expr
);
2105 /* Initialize the result. */
2106 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2107 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2108 type
= gfc_typenode_for_spec (&expr
->ts
);
2110 /* Walk the arguments. */
2111 actual
= expr
->value
.function
.actual
;
2112 arrayexpr
= actual
->expr
;
2113 arrayss
= gfc_walk_expr (arrayexpr
);
2114 gcc_assert (arrayss
!= gfc_ss_terminator
);
2116 actual
= actual
->next
->next
;
2117 gcc_assert (actual
);
2118 maskexpr
= actual
->expr
;
2119 if (maskexpr
&& maskexpr
->rank
!= 0)
2121 maskss
= gfc_walk_expr (maskexpr
);
2122 gcc_assert (maskss
!= gfc_ss_terminator
);
2127 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2128 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2129 switch (arrayexpr
->ts
.type
)
2132 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
2136 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2137 arrayexpr
->ts
.kind
);
2144 /* We start with the most negative possible value for MAXLOC, and the most
2145 positive possible value for MINLOC. The most negative possible value is
2146 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2147 possible value is HUGE in both cases. */
2149 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2150 gfc_add_modify (&se
->pre
, limit
, tmp
);
2152 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2153 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2154 build_int_cst (type
, 1));
2156 /* Initialize the scalarizer. */
2157 gfc_init_loopinfo (&loop
);
2158 gfc_add_ss_to_loop (&loop
, arrayss
);
2160 gfc_add_ss_to_loop (&loop
, maskss
);
2162 /* Initialize the loop. */
2163 gfc_conv_ss_startstride (&loop
);
2164 gfc_conv_loop_setup (&loop
, &expr
->where
);
2166 gcc_assert (loop
.dimen
== 1);
2168 /* Initialize the position to zero, following Fortran 2003. We are free
2169 to do this because Fortran 95 allows the result of an entirely false
2170 mask to be processor dependent. */
2171 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
2173 gfc_mark_ss_chain_used (arrayss
, 1);
2175 gfc_mark_ss_chain_used (maskss
, 1);
2176 /* Generate the loop body. */
2177 gfc_start_scalarized_body (&loop
, &body
);
2179 /* If we have a mask, only check this element if the mask is set. */
2182 gfc_init_se (&maskse
, NULL
);
2183 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2185 gfc_conv_expr_val (&maskse
, maskexpr
);
2186 gfc_add_block_to_block (&body
, &maskse
.pre
);
2188 gfc_start_block (&block
);
2191 gfc_init_block (&block
);
2193 /* Compare with the current limit. */
2194 gfc_init_se (&arrayse
, NULL
);
2195 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2196 arrayse
.ss
= arrayss
;
2197 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2198 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2200 /* We do the following if this is a more extreme value. */
2201 gfc_start_block (&ifblock
);
2203 /* Assign the value to the limit... */
2204 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2206 /* Remember where we are. An offset must be added to the loop
2207 counter to obtain the required position. */
2209 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2210 gfc_index_one_node
, loop
.from
[0]);
2212 tmp
= gfc_index_one_node
;
2214 gfc_add_modify (&block
, offset
, tmp
);
2216 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2217 loop
.loopvar
[0], offset
);
2218 gfc_add_modify (&ifblock
, pos
, tmp
);
2220 ifbody
= gfc_finish_block (&ifblock
);
2222 /* If it is a more extreme value or pos is still zero and the value
2223 equal to the limit. */
2224 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2225 fold_build2 (EQ_EXPR
, boolean_type_node
,
2226 pos
, gfc_index_zero_node
),
2227 fold_build2 (EQ_EXPR
, boolean_type_node
,
2228 arrayse
.expr
, limit
));
2229 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2230 fold_build2 (op
, boolean_type_node
,
2231 arrayse
.expr
, limit
), tmp
);
2232 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2233 gfc_add_expr_to_block (&block
, tmp
);
2237 /* We enclose the above in if (mask) {...}. */
2238 tmp
= gfc_finish_block (&block
);
2240 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2243 tmp
= gfc_finish_block (&block
);
2244 gfc_add_expr_to_block (&body
, tmp
);
2246 gfc_trans_scalarizing_loops (&loop
, &body
);
2248 /* For a scalar mask, enclose the loop in an if statement. */
2249 if (maskexpr
&& maskss
== NULL
)
2251 gfc_init_se (&maskse
, NULL
);
2252 gfc_conv_expr_val (&maskse
, maskexpr
);
2253 gfc_init_block (&block
);
2254 gfc_add_block_to_block (&block
, &loop
.pre
);
2255 gfc_add_block_to_block (&block
, &loop
.post
);
2256 tmp
= gfc_finish_block (&block
);
2258 /* For the else part of the scalar mask, just initialize
2259 the pos variable the same way as above. */
2261 gfc_init_block (&elseblock
);
2262 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
2263 elsetmp
= gfc_finish_block (&elseblock
);
2265 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2266 gfc_add_expr_to_block (&block
, tmp
);
2267 gfc_add_block_to_block (&se
->pre
, &block
);
2271 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2272 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2274 gfc_cleanup_loop (&loop
);
2276 se
->expr
= convert (type
, pos
);
2280 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
2289 gfc_actual_arglist
*actual
;
2294 gfc_expr
*arrayexpr
;
2300 gfc_conv_intrinsic_funcall (se
, expr
);
2304 type
= gfc_typenode_for_spec (&expr
->ts
);
2305 /* Initialize the result. */
2306 limit
= gfc_create_var (type
, "limit");
2307 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2308 switch (expr
->ts
.type
)
2311 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
2315 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2322 /* We start with the most negative possible value for MAXVAL, and the most
2323 positive possible value for MINVAL. The most negative possible value is
2324 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2325 possible value is HUGE in both cases. */
2327 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2329 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2330 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
),
2331 tmp
, build_int_cst (type
, 1));
2333 gfc_add_modify (&se
->pre
, limit
, tmp
);
2335 /* Walk the arguments. */
2336 actual
= expr
->value
.function
.actual
;
2337 arrayexpr
= actual
->expr
;
2338 arrayss
= gfc_walk_expr (arrayexpr
);
2339 gcc_assert (arrayss
!= gfc_ss_terminator
);
2341 actual
= actual
->next
->next
;
2342 gcc_assert (actual
);
2343 maskexpr
= actual
->expr
;
2344 if (maskexpr
&& maskexpr
->rank
!= 0)
2346 maskss
= gfc_walk_expr (maskexpr
);
2347 gcc_assert (maskss
!= gfc_ss_terminator
);
2352 /* Initialize the scalarizer. */
2353 gfc_init_loopinfo (&loop
);
2354 gfc_add_ss_to_loop (&loop
, arrayss
);
2356 gfc_add_ss_to_loop (&loop
, maskss
);
2358 /* Initialize the loop. */
2359 gfc_conv_ss_startstride (&loop
);
2360 gfc_conv_loop_setup (&loop
, &expr
->where
);
2362 gfc_mark_ss_chain_used (arrayss
, 1);
2364 gfc_mark_ss_chain_used (maskss
, 1);
2365 /* Generate the loop body. */
2366 gfc_start_scalarized_body (&loop
, &body
);
2368 /* If we have a mask, only add this element if the mask is set. */
2371 gfc_init_se (&maskse
, NULL
);
2372 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2374 gfc_conv_expr_val (&maskse
, maskexpr
);
2375 gfc_add_block_to_block (&body
, &maskse
.pre
);
2377 gfc_start_block (&block
);
2380 gfc_init_block (&block
);
2382 /* Compare with the current limit. */
2383 gfc_init_se (&arrayse
, NULL
);
2384 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2385 arrayse
.ss
= arrayss
;
2386 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2387 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2389 /* Assign the value to the limit... */
2390 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2392 /* If it is a more extreme value. */
2393 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2394 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2395 gfc_add_expr_to_block (&block
, tmp
);
2396 gfc_add_block_to_block (&block
, &arrayse
.post
);
2398 tmp
= gfc_finish_block (&block
);
2400 /* We enclose the above in if (mask) {...}. */
2401 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2402 gfc_add_expr_to_block (&body
, tmp
);
2404 gfc_trans_scalarizing_loops (&loop
, &body
);
2406 /* For a scalar mask, enclose the loop in an if statement. */
2407 if (maskexpr
&& maskss
== NULL
)
2409 gfc_init_se (&maskse
, NULL
);
2410 gfc_conv_expr_val (&maskse
, maskexpr
);
2411 gfc_init_block (&block
);
2412 gfc_add_block_to_block (&block
, &loop
.pre
);
2413 gfc_add_block_to_block (&block
, &loop
.post
);
2414 tmp
= gfc_finish_block (&block
);
2416 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2417 gfc_add_expr_to_block (&block
, tmp
);
2418 gfc_add_block_to_block (&se
->pre
, &block
);
2422 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2423 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2426 gfc_cleanup_loop (&loop
);
2431 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2433 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2439 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2440 type
= TREE_TYPE (args
[0]);
2442 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2443 tmp
= fold_build2 (BIT_AND_EXPR
, type
, args
[0], tmp
);
2444 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2445 build_int_cst (type
, 0));
2446 type
= gfc_typenode_for_spec (&expr
->ts
);
2447 se
->expr
= convert (type
, tmp
);
2450 /* Generate code to perform the specified operation. */
2452 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
2456 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2457 se
->expr
= fold_build2 (op
, TREE_TYPE (args
[0]), args
[0], args
[1]);
2462 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2466 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2467 se
->expr
= fold_build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2470 /* Set or clear a single bit. */
2472 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2479 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2480 type
= TREE_TYPE (args
[0]);
2482 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2488 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2490 se
->expr
= fold_build2 (op
, type
, args
[0], tmp
);
2493 /* Extract a sequence of bits.
2494 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2496 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2503 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2504 type
= TREE_TYPE (args
[0]);
2506 mask
= build_int_cst (type
, -1);
2507 mask
= fold_build2 (LSHIFT_EXPR
, type
, mask
, args
[2]);
2508 mask
= fold_build1 (BIT_NOT_EXPR
, type
, mask
);
2510 tmp
= fold_build2 (RSHIFT_EXPR
, type
, args
[0], args
[1]);
2512 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2515 /* RSHIFT (I, SHIFT) = I >> SHIFT
2516 LSHIFT (I, SHIFT) = I << SHIFT */
2518 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
2522 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2524 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
2525 TREE_TYPE (args
[0]), args
[0], args
[1]);
2528 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2530 : ((shift >= 0) ? i << shift : i >> -shift)
2531 where all shifts are logical shifts. */
2533 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2545 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2546 type
= TREE_TYPE (args
[0]);
2547 utype
= unsigned_type_for (type
);
2549 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2551 /* Left shift if positive. */
2552 lshift
= fold_build2 (LSHIFT_EXPR
, type
, args
[0], width
);
2554 /* Right shift if negative.
2555 We convert to an unsigned type because we want a logical shift.
2556 The standard doesn't define the case of shifting negative
2557 numbers, and we try to be compatible with other compilers, most
2558 notably g77, here. */
2559 rshift
= fold_convert (type
, fold_build2 (RSHIFT_EXPR
, utype
,
2560 convert (utype
, args
[0]), width
));
2562 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, args
[1],
2563 build_int_cst (TREE_TYPE (args
[1]), 0));
2564 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2566 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2567 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2569 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
2570 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2572 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2573 build_int_cst (type
, 0), tmp
);
2577 /* Circular shift. AKA rotate or barrel shift. */
2580 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2588 unsigned int num_args
;
2590 num_args
= gfc_intrinsic_argument_list_length (expr
);
2591 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
2593 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2597 /* Use a library function for the 3 parameter version. */
2598 tree int4type
= gfc_get_int_type (4);
2600 type
= TREE_TYPE (args
[0]);
2601 /* We convert the first argument to at least 4 bytes, and
2602 convert back afterwards. This removes the need for library
2603 functions for all argument sizes, and function will be
2604 aligned to at least 32 bits, so there's no loss. */
2605 if (expr
->ts
.kind
< 4)
2606 args
[0] = convert (int4type
, args
[0]);
2608 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2609 need loads of library functions. They cannot have values >
2610 BIT_SIZE (I) so the conversion is safe. */
2611 args
[1] = convert (int4type
, args
[1]);
2612 args
[2] = convert (int4type
, args
[2]);
2614 switch (expr
->ts
.kind
)
2619 tmp
= gfor_fndecl_math_ishftc4
;
2622 tmp
= gfor_fndecl_math_ishftc8
;
2625 tmp
= gfor_fndecl_math_ishftc16
;
2630 se
->expr
= build_call_expr (tmp
, 3, args
[0], args
[1], args
[2]);
2631 /* Convert the result back to the original type, if we extended
2632 the first argument's width above. */
2633 if (expr
->ts
.kind
< 4)
2634 se
->expr
= convert (type
, se
->expr
);
2638 type
= TREE_TYPE (args
[0]);
2640 /* Rotate left if positive. */
2641 lrot
= fold_build2 (LROTATE_EXPR
, type
, args
[0], args
[1]);
2643 /* Rotate right if negative. */
2644 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2645 rrot
= fold_build2 (RROTATE_EXPR
, type
, args
[0], tmp
);
2647 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
2648 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, args
[1], zero
);
2649 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2651 /* Do nothing if shift == 0. */
2652 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
2653 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, args
[0], rrot
);
2656 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
2657 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
2659 The conditional expression is necessary because the result of LEADZ(0)
2660 is defined, but the result of __builtin_clz(0) is undefined for most
2663 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
2664 difference in bit size between the argument of LEADZ and the C int. */
2667 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
2679 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2681 /* Which variant of __builtin_clz* should we call? */
2682 arg_kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
2683 i
= gfc_validate_kind (BT_INTEGER
, arg_kind
, false);
2689 arg_type
= unsigned_type_node
;
2694 arg_type
= long_unsigned_type_node
;
2699 arg_type
= long_long_unsigned_type_node
;
2707 /* Convert the actual argument to the proper argument type for the built-in
2708 function. But the return type is of the default INTEGER kind. */
2709 arg
= fold_convert (arg_type
, arg
);
2710 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
2712 /* Compute LEADZ for the case i .ne. 0. */
2713 s
= TYPE_PRECISION (arg_type
) - gfc_integer_kinds
[i
].bit_size
;
2714 tmp
= fold_convert (result_type
, build_call_expr (built_in_decls
[n
], 1, arg
));
2715 leadz
= fold_build2 (MINUS_EXPR
, result_type
,
2716 tmp
, build_int_cst (result_type
, s
));
2718 /* Build BIT_SIZE. */
2719 bit_size
= build_int_cst (result_type
, gfc_integer_kinds
[i
].bit_size
);
2721 /* ??? For some combinations of targets and integer kinds, the condition
2722 can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used. Later. */
2723 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2724 arg
, build_int_cst (arg_type
, 0));
2725 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, leadz
);
2728 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
2730 The conditional expression is necessary because the result of TRAILZ(0)
2731 is defined, but the result of __builtin_ctz(0) is undefined for most
2735 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
2746 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2748 /* Which variant of __builtin_clz* should we call? */
2749 arg_kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
2750 i
= gfc_validate_kind (BT_INTEGER
, arg_kind
, false);
2751 switch (expr
->ts
.kind
)
2756 arg_type
= unsigned_type_node
;
2761 arg_type
= long_unsigned_type_node
;
2766 arg_type
= long_long_unsigned_type_node
;
2774 /* Convert the actual argument to the proper argument type for the built-in
2775 function. But the return type is of the default INTEGER kind. */
2776 arg
= fold_convert (arg_type
, arg
);
2777 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
2779 /* Compute TRAILZ for the case i .ne. 0. */
2780 trailz
= fold_convert (result_type
, build_call_expr (built_in_decls
[n
], 1, arg
));
2782 /* Build BIT_SIZE. */
2783 bit_size
= build_int_cst (result_type
, gfc_integer_kinds
[i
].bit_size
);
2785 /* ??? For some combinations of targets and integer kinds, the condition
2786 can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used. Later. */
2787 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2788 arg
, build_int_cst (arg_type
, 0));
2789 se
->expr
= fold_build3 (COND_EXPR
, result_type
, cond
, bit_size
, trailz
);
2792 /* Process an intrinsic with unspecified argument-types that has an optional
2793 argument (which could be of type character), e.g. EOSHIFT. For those, we
2794 need to append the string length of the optional argument if it is not
2795 present and the type is really character.
2796 primary specifies the position (starting at 1) of the non-optional argument
2797 specifying the type and optional gives the position of the optional
2798 argument in the arglist. */
2801 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
2802 unsigned primary
, unsigned optional
)
2804 gfc_actual_arglist
* prim_arg
;
2805 gfc_actual_arglist
* opt_arg
;
2807 gfc_actual_arglist
* arg
;
2811 /* Find the two arguments given as position. */
2815 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2819 if (cur_pos
== primary
)
2821 if (cur_pos
== optional
)
2824 if (cur_pos
>= primary
&& cur_pos
>= optional
)
2827 gcc_assert (prim_arg
);
2828 gcc_assert (prim_arg
->expr
);
2829 gcc_assert (opt_arg
);
2831 /* If we do have type CHARACTER and the optional argument is really absent,
2832 append a dummy 0 as string length. */
2833 append_args
= NULL_TREE
;
2834 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
2838 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
2839 append_args
= gfc_chainon_list (append_args
, dummy
);
2842 /* Build the call itself. */
2843 sym
= gfc_get_symbol_for_expr (expr
);
2844 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
2849 /* The length of a character string. */
2851 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2861 gcc_assert (!se
->ss
);
2863 arg
= expr
->value
.function
.actual
->expr
;
2865 type
= gfc_typenode_for_spec (&expr
->ts
);
2866 switch (arg
->expr_type
)
2869 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2873 /* Obtain the string length from the function used by
2874 trans-array.c(gfc_trans_array_constructor). */
2876 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
2880 if (arg
->ref
== NULL
2881 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
2883 /* This doesn't catch all cases.
2884 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2885 and the surrounding thread. */
2886 sym
= arg
->symtree
->n
.sym
;
2887 decl
= gfc_get_symbol_decl (sym
);
2888 if (decl
== current_function_decl
&& sym
->attr
.function
2889 && (sym
->result
== sym
))
2890 decl
= gfc_get_fake_result_decl (sym
, 0);
2892 len
= sym
->ts
.cl
->backend_decl
;
2897 /* Otherwise fall through. */
2900 /* Anybody stupid enough to do this deserves inefficient code. */
2901 ss
= gfc_walk_expr (arg
);
2902 gfc_init_se (&argse
, se
);
2903 if (ss
== gfc_ss_terminator
)
2904 gfc_conv_expr (&argse
, arg
);
2906 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2907 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2908 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2909 len
= argse
.string_length
;
2912 se
->expr
= convert (type
, len
);
2915 /* The length of a character string not including trailing blanks. */
2917 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2919 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
2920 tree args
[2], type
, fndecl
;
2922 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2923 type
= gfc_typenode_for_spec (&expr
->ts
);
2926 fndecl
= gfor_fndecl_string_len_trim
;
2928 fndecl
= gfor_fndecl_string_len_trim_char4
;
2932 se
->expr
= build_call_expr (fndecl
, 2, args
[0], args
[1]);
2933 se
->expr
= convert (type
, se
->expr
);
2937 /* Returns the starting position of a substring within a string. */
2940 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
2943 tree logical4_type_node
= gfc_get_logical_type (4);
2947 unsigned int num_args
;
2949 args
= (tree
*) alloca (sizeof (tree
) * 5);
2951 /* Get number of arguments; characters count double due to the
2952 string length argument. Kind= is not passed to the library
2953 and thus ignored. */
2954 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
2959 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2960 type
= gfc_typenode_for_spec (&expr
->ts
);
2963 args
[4] = build_int_cst (logical4_type_node
, 0);
2965 args
[4] = convert (logical4_type_node
, args
[4]);
2967 fndecl
= build_addr (function
, current_function_decl
);
2968 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2970 se
->expr
= convert (type
, se
->expr
);
2974 /* The ascii value for a single character. */
2976 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2978 tree args
[2], type
, pchartype
;
2980 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2981 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
2982 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
2983 args
[1] = fold_build1 (NOP_EXPR
, pchartype
, args
[1]);
2984 type
= gfc_typenode_for_spec (&expr
->ts
);
2986 se
->expr
= build_fold_indirect_ref (args
[1]);
2987 se
->expr
= convert (type
, se
->expr
);
2991 /* Intrinsic ISNAN calls __builtin_isnan. */
2994 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
2998 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2999 se
->expr
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
3000 STRIP_TYPE_NOPS (se
->expr
);
3001 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3005 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3006 their argument against a constant integer value. */
3009 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
3013 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3014 se
->expr
= fold_build2 (EQ_EXPR
, gfc_typenode_for_spec (&expr
->ts
),
3015 arg
, build_int_cst (TREE_TYPE (arg
), value
));
3020 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3023 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
3031 unsigned int num_args
;
3033 num_args
= gfc_intrinsic_argument_list_length (expr
);
3034 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
3036 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3037 if (expr
->ts
.type
!= BT_CHARACTER
)
3045 /* We do the same as in the non-character case, but the argument
3046 list is different because of the string length arguments. We
3047 also have to set the string length for the result. */
3053 se
->string_length
= len
;
3055 type
= TREE_TYPE (tsource
);
3056 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
,
3057 fold_convert (type
, fsource
));
3061 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3063 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
3065 tree arg
, type
, tmp
;
3068 switch (expr
->ts
.kind
)
3071 frexp
= BUILT_IN_FREXPF
;
3074 frexp
= BUILT_IN_FREXP
;
3078 frexp
= BUILT_IN_FREXPL
;
3084 type
= gfc_typenode_for_spec (&expr
->ts
);
3085 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3086 tmp
= gfc_create_var (integer_type_node
, NULL
);
3087 se
->expr
= build_call_expr (built_in_decls
[frexp
], 2,
3088 fold_convert (type
, arg
),
3089 build_fold_addr_expr (tmp
));
3090 se
->expr
= fold_convert (type
, se
->expr
);
3094 /* NEAREST (s, dir) is translated into
3095 tmp = copysign (INF, dir);
3096 return nextafter (s, tmp);
3099 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
3101 tree args
[2], type
, tmp
;
3102 int nextafter
, copysign
, inf
;
3104 switch (expr
->ts
.kind
)
3107 nextafter
= BUILT_IN_NEXTAFTERF
;
3108 copysign
= BUILT_IN_COPYSIGNF
;
3109 inf
= BUILT_IN_INFF
;
3112 nextafter
= BUILT_IN_NEXTAFTER
;
3113 copysign
= BUILT_IN_COPYSIGN
;
3118 nextafter
= BUILT_IN_NEXTAFTERL
;
3119 copysign
= BUILT_IN_COPYSIGNL
;
3120 inf
= BUILT_IN_INFL
;
3126 type
= gfc_typenode_for_spec (&expr
->ts
);
3127 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3128 tmp
= build_call_expr (built_in_decls
[copysign
], 2,
3129 build_call_expr (built_in_decls
[inf
], 0),
3130 fold_convert (type
, args
[1]));
3131 se
->expr
= build_call_expr (built_in_decls
[nextafter
], 2,
3132 fold_convert (type
, args
[0]), tmp
);
3133 se
->expr
= fold_convert (type
, se
->expr
);
3137 /* SPACING (s) is translated into
3145 e = MAX_EXPR (e, emin);
3146 res = scalbn (1., e);
3150 where prec is the precision of s, gfc_real_kinds[k].digits,
3151 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3152 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3155 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
3157 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
3159 int frexp
, scalbn
, k
;
3162 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3163 prec
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].digits
);
3164 emin
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].min_exponent
- 1);
3165 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
);
3167 switch (expr
->ts
.kind
)
3170 frexp
= BUILT_IN_FREXPF
;
3171 scalbn
= BUILT_IN_SCALBNF
;
3174 frexp
= BUILT_IN_FREXP
;
3175 scalbn
= BUILT_IN_SCALBN
;
3179 frexp
= BUILT_IN_FREXPL
;
3180 scalbn
= BUILT_IN_SCALBNL
;
3186 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3187 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3189 type
= gfc_typenode_for_spec (&expr
->ts
);
3190 e
= gfc_create_var (integer_type_node
, NULL
);
3191 res
= gfc_create_var (type
, NULL
);
3194 /* Build the block for s /= 0. */
3195 gfc_start_block (&block
);
3196 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
3197 build_fold_addr_expr (e
));
3198 gfc_add_expr_to_block (&block
, tmp
);
3200 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, e
, prec
);
3201 gfc_add_modify (&block
, e
, fold_build2 (MAX_EXPR
, integer_type_node
,
3204 tmp
= build_call_expr (built_in_decls
[scalbn
], 2,
3205 build_real_from_int_cst (type
, integer_one_node
), e
);
3206 gfc_add_modify (&block
, res
, tmp
);
3208 /* Finish by building the IF statement. */
3209 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg
,
3210 build_real_from_int_cst (type
, integer_zero_node
));
3211 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
3212 gfc_finish_block (&block
));
3214 gfc_add_expr_to_block (&se
->pre
, tmp
);
3219 /* RRSPACING (s) is translated into
3226 x = scalbn (x, precision - e);
3230 where precision is gfc_real_kinds[k].digits. */
3233 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
3235 tree arg
, type
, e
, x
, cond
, stmt
, tmp
;
3236 int frexp
, scalbn
, fabs
, prec
, k
;
3239 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3240 prec
= gfc_real_kinds
[k
].digits
;
3241 switch (expr
->ts
.kind
)
3244 frexp
= BUILT_IN_FREXPF
;
3245 scalbn
= BUILT_IN_SCALBNF
;
3246 fabs
= BUILT_IN_FABSF
;
3249 frexp
= BUILT_IN_FREXP
;
3250 scalbn
= BUILT_IN_SCALBN
;
3251 fabs
= BUILT_IN_FABS
;
3255 frexp
= BUILT_IN_FREXPL
;
3256 scalbn
= BUILT_IN_SCALBNL
;
3257 fabs
= BUILT_IN_FABSL
;
3263 type
= gfc_typenode_for_spec (&expr
->ts
);
3264 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3265 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3267 e
= gfc_create_var (integer_type_node
, NULL
);
3268 x
= gfc_create_var (type
, NULL
);
3269 gfc_add_modify (&se
->pre
, x
,
3270 build_call_expr (built_in_decls
[fabs
], 1, arg
));
3273 gfc_start_block (&block
);
3274 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
3275 build_fold_addr_expr (e
));
3276 gfc_add_expr_to_block (&block
, tmp
);
3278 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
,
3279 build_int_cst (NULL_TREE
, prec
), e
);
3280 tmp
= build_call_expr (built_in_decls
[scalbn
], 2, x
, tmp
);
3281 gfc_add_modify (&block
, x
, tmp
);
3282 stmt
= gfc_finish_block (&block
);
3284 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, x
,
3285 build_real_from_int_cst (type
, integer_zero_node
));
3286 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt ());
3287 gfc_add_expr_to_block (&se
->pre
, tmp
);
3289 se
->expr
= fold_convert (type
, x
);
3293 /* SCALE (s, i) is translated into scalbn (s, i). */
3295 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
3300 switch (expr
->ts
.kind
)
3303 scalbn
= BUILT_IN_SCALBNF
;
3306 scalbn
= BUILT_IN_SCALBN
;
3310 scalbn
= BUILT_IN_SCALBNL
;
3316 type
= gfc_typenode_for_spec (&expr
->ts
);
3317 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3318 se
->expr
= build_call_expr (built_in_decls
[scalbn
], 2,
3319 fold_convert (type
, args
[0]),
3320 fold_convert (integer_type_node
, args
[1]));
3321 se
->expr
= fold_convert (type
, se
->expr
);
3325 /* SET_EXPONENT (s, i) is translated into
3326 scalbn (frexp (s, &dummy_int), i). */
3328 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
3330 tree args
[2], type
, tmp
;
3333 switch (expr
->ts
.kind
)
3336 frexp
= BUILT_IN_FREXPF
;
3337 scalbn
= BUILT_IN_SCALBNF
;
3340 frexp
= BUILT_IN_FREXP
;
3341 scalbn
= BUILT_IN_SCALBN
;
3345 frexp
= BUILT_IN_FREXPL
;
3346 scalbn
= BUILT_IN_SCALBNL
;
3352 type
= gfc_typenode_for_spec (&expr
->ts
);
3353 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3355 tmp
= gfc_create_var (integer_type_node
, NULL
);
3356 tmp
= build_call_expr (built_in_decls
[frexp
], 2,
3357 fold_convert (type
, args
[0]),
3358 build_fold_addr_expr (tmp
));
3359 se
->expr
= build_call_expr (built_in_decls
[scalbn
], 2, tmp
,
3360 fold_convert (integer_type_node
, args
[1]));
3361 se
->expr
= fold_convert (type
, se
->expr
);
3366 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
3368 gfc_actual_arglist
*actual
;
3376 gfc_init_se (&argse
, NULL
);
3377 actual
= expr
->value
.function
.actual
;
3379 ss
= gfc_walk_expr (actual
->expr
);
3380 gcc_assert (ss
!= gfc_ss_terminator
);
3381 argse
.want_pointer
= 1;
3382 argse
.data_not_needed
= 1;
3383 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
3384 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3385 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3386 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
3388 /* Build the call to size0. */
3389 fncall0
= build_call_expr (gfor_fndecl_size0
, 1, arg1
);
3391 actual
= actual
->next
;
3395 gfc_init_se (&argse
, NULL
);
3396 gfc_conv_expr_type (&argse
, actual
->expr
,
3397 gfc_array_index_type
);
3398 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3400 /* Unusually, for an intrinsic, size does not exclude
3401 an optional arg2, so we must test for it. */
3402 if (actual
->expr
->expr_type
== EXPR_VARIABLE
3403 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
3404 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
3407 /* Build the call to size1. */
3408 fncall1
= build_call_expr (gfor_fndecl_size1
, 2,
3411 gfc_init_se (&argse
, NULL
);
3412 argse
.want_pointer
= 1;
3413 argse
.data_not_needed
= 1;
3414 gfc_conv_expr (&argse
, actual
->expr
);
3415 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3416 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3417 argse
.expr
, null_pointer_node
);
3418 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3419 se
->expr
= fold_build3 (COND_EXPR
, pvoid_type_node
,
3420 tmp
, fncall1
, fncall0
);
3424 se
->expr
= NULL_TREE
;
3425 argse
.expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3426 argse
.expr
, gfc_index_one_node
);
3429 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
3431 argse
.expr
= gfc_index_zero_node
;
3432 se
->expr
= NULL_TREE
;
3437 if (se
->expr
== NULL_TREE
)
3439 tree ubound
, lbound
;
3441 arg1
= build_fold_indirect_ref (arg1
);
3442 ubound
= gfc_conv_descriptor_ubound (arg1
, argse
.expr
);
3443 lbound
= gfc_conv_descriptor_lbound (arg1
, argse
.expr
);
3444 se
->expr
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3446 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
->expr
,
3447 gfc_index_one_node
);
3448 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
3449 gfc_index_zero_node
);
3452 type
= gfc_typenode_for_spec (&expr
->ts
);
3453 se
->expr
= convert (type
, se
->expr
);
3457 /* Helper function to compute the size of a character variable,
3458 excluding the terminating null characters. The result has
3459 gfc_array_index_type type. */
3462 size_of_string_in_bytes (int kind
, tree string_length
)
3465 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
3467 bytesize
= build_int_cst (gfc_array_index_type
,
3468 gfc_character_kinds
[i
].bit_size
/ 8);
3470 return fold_build2 (MULT_EXPR
, gfc_array_index_type
, bytesize
,
3471 fold_convert (gfc_array_index_type
, string_length
));
3476 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
3489 arg
= expr
->value
.function
.actual
->expr
;
3491 gfc_init_se (&argse
, NULL
);
3492 ss
= gfc_walk_expr (arg
);
3494 if (ss
== gfc_ss_terminator
)
3496 gfc_conv_expr_reference (&argse
, arg
);
3497 source
= argse
.expr
;
3499 type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3501 /* Obtain the source word length. */
3502 if (arg
->ts
.type
== BT_CHARACTER
)
3503 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
3504 argse
.string_length
);
3506 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
3510 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
3511 argse
.want_pointer
= 0;
3512 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3513 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3514 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3516 /* Obtain the argument's word length. */
3517 if (arg
->ts
.type
== BT_CHARACTER
)
3518 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
3520 tmp
= fold_convert (gfc_array_index_type
,
3521 size_in_bytes (type
));
3522 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3524 /* Obtain the size of the array in bytes. */
3525 for (n
= 0; n
< arg
->rank
; n
++)
3528 idx
= gfc_rank_cst
[n
];
3529 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3530 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3531 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3533 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3534 tmp
, gfc_index_one_node
);
3535 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3537 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3539 se
->expr
= source_bytes
;
3542 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3546 /* Intrinsic string comparison functions. */
3549 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
3553 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
3556 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
3557 expr
->value
.function
.actual
->expr
->ts
.kind
);
3558 se
->expr
= fold_build2 (op
, gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
3559 build_int_cst (TREE_TYPE (se
->expr
), 0));
3562 /* Generate a call to the adjustl/adjustr library function. */
3564 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
3572 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
3575 type
= TREE_TYPE (args
[2]);
3576 var
= gfc_conv_string_tmp (se
, type
, len
);
3579 tmp
= build_call_expr (fndecl
, 3, args
[0], args
[1], args
[2]);
3580 gfc_add_expr_to_block (&se
->pre
, tmp
);
3582 se
->string_length
= len
;
3586 /* Array transfer statement.
3587 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3589 typeof<DEST> = typeof<MOLD>
3591 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3592 sizeof (DEST(0) * SIZE). */
3595 gfc_conv_intrinsic_array_transfer (gfc_se
* se
, gfc_expr
* expr
)
3610 gfc_actual_arglist
*arg
;
3617 gcc_assert (se
->loop
);
3618 info
= &se
->ss
->data
.info
;
3620 /* Convert SOURCE. The output from this stage is:-
3621 source_bytes = length of the source in bytes
3622 source = pointer to the source data. */
3623 arg
= expr
->value
.function
.actual
;
3624 gfc_init_se (&argse
, NULL
);
3625 ss
= gfc_walk_expr (arg
->expr
);
3627 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3629 /* Obtain the pointer to source and the length of source in bytes. */
3630 if (ss
== gfc_ss_terminator
)
3632 gfc_conv_expr_reference (&argse
, arg
->expr
);
3633 source
= argse
.expr
;
3635 source_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3637 /* Obtain the source word length. */
3638 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3639 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
3640 argse
.string_length
);
3642 tmp
= fold_convert (gfc_array_index_type
,
3643 size_in_bytes (source_type
));
3647 argse
.want_pointer
= 0;
3648 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3649 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3650 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3652 /* Repack the source if not a full variable array. */
3653 if (!(arg
->expr
->expr_type
== EXPR_VARIABLE
3654 && arg
->expr
->ref
->u
.ar
.type
== AR_FULL
))
3656 tmp
= build_fold_addr_expr (argse
.expr
);
3658 if (gfc_option
.warn_array_temp
)
3659 gfc_warning ("Creating array temporary at %L", &expr
->where
);
3661 source
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
3662 source
= gfc_evaluate_now (source
, &argse
.pre
);
3664 /* Free the temporary. */
3665 gfc_start_block (&block
);
3666 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
3667 gfc_add_expr_to_block (&block
, tmp
);
3668 stmt
= gfc_finish_block (&block
);
3670 /* Clean up if it was repacked. */
3671 gfc_init_block (&block
);
3672 tmp
= gfc_conv_array_data (argse
.expr
);
3673 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
3674 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3675 gfc_add_expr_to_block (&block
, tmp
);
3676 gfc_add_block_to_block (&block
, &se
->post
);
3677 gfc_init_block (&se
->post
);
3678 gfc_add_block_to_block (&se
->post
, &block
);
3681 /* Obtain the source word length. */
3682 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3683 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
3684 argse
.string_length
);
3686 tmp
= fold_convert (gfc_array_index_type
,
3687 size_in_bytes (source_type
));
3689 /* Obtain the size of the array in bytes. */
3690 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
3691 for (n
= 0; n
< arg
->expr
->rank
; n
++)
3694 idx
= gfc_rank_cst
[n
];
3695 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3696 stride
= gfc_conv_descriptor_stride (argse
.expr
, idx
);
3697 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3698 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3699 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3701 gfc_add_modify (&argse
.pre
, extent
, tmp
);
3702 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3703 extent
, gfc_index_one_node
);
3704 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3709 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
3710 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3711 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3713 /* Now convert MOLD. The outputs are:
3714 mold_type = the TREE type of MOLD
3715 dest_word_len = destination word length in bytes. */
3718 gfc_init_se (&argse
, NULL
);
3719 ss
= gfc_walk_expr (arg
->expr
);
3721 if (ss
== gfc_ss_terminator
)
3723 gfc_conv_expr_reference (&argse
, arg
->expr
);
3724 mold_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3728 gfc_init_se (&argse
, NULL
);
3729 argse
.want_pointer
= 0;
3730 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3731 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3734 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
3736 /* If this TRANSFER is nested in another TRANSFER, use a type
3737 that preserves all bits. */
3738 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
3739 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
3742 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3744 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
3745 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
3748 tmp
= fold_convert (gfc_array_index_type
,
3749 size_in_bytes (mold_type
));
3751 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
3752 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
3754 /* Finally convert SIZE, if it is present. */
3756 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
3760 gfc_init_se (&argse
, NULL
);
3761 gfc_conv_expr_reference (&argse
, arg
->expr
);
3762 tmp
= convert (gfc_array_index_type
,
3763 build_fold_indirect_ref (argse
.expr
));
3764 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3765 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3770 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3771 if (tmp
!= NULL_TREE
)
3773 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3774 tmp
, dest_word_len
);
3775 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3781 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
3782 gfc_add_modify (&se
->pre
, size_words
,
3783 fold_build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
3784 size_bytes
, dest_word_len
));
3786 /* Evaluate the bounds of the result. If the loop range exists, we have
3787 to check if it is too large. If so, we modify loop->to be consistent
3788 with min(size, size(source)). Otherwise, size is made consistent with
3789 the loop range, so that the right number of bytes is transferred.*/
3790 n
= se
->loop
->order
[0];
3791 if (se
->loop
->to
[n
] != NULL_TREE
)
3793 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3794 se
->loop
->to
[n
], se
->loop
->from
[n
]);
3795 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3796 tmp
, gfc_index_one_node
);
3797 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3799 gfc_add_modify (&se
->pre
, size_words
, tmp
);
3800 gfc_add_modify (&se
->pre
, size_bytes
,
3801 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3802 size_words
, dest_word_len
));
3803 upper
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3804 size_words
, se
->loop
->from
[n
]);
3805 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3806 upper
, gfc_index_one_node
);
3810 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3811 size_words
, gfc_index_one_node
);
3812 se
->loop
->from
[n
] = gfc_index_zero_node
;
3815 se
->loop
->to
[n
] = upper
;
3817 /* Build a destination descriptor, using the pointer, source, as the
3818 data field. This is already allocated so set callee_alloc.
3819 FIXME callee_alloc is not set! */
3821 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
3822 info
, mold_type
, NULL_TREE
, false, true, false,
3825 /* Cast the pointer to the result. */
3826 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3827 tmp
= fold_convert (pvoid_type_node
, tmp
);
3829 /* Use memcpy to do the transfer. */
3830 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
],
3833 fold_convert (pvoid_type_node
, source
),
3835 gfc_add_expr_to_block (&se
->pre
, tmp
);
3837 se
->expr
= info
->descriptor
;
3838 if (expr
->ts
.type
== BT_CHARACTER
)
3839 se
->string_length
= dest_word_len
;
3843 /* Scalar transfer statement.
3844 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3847 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
3849 gfc_actual_arglist
*arg
;
3856 /* Get a pointer to the source. */
3857 arg
= expr
->value
.function
.actual
;
3858 ss
= gfc_walk_expr (arg
->expr
);
3859 gfc_init_se (&argse
, NULL
);
3860 if (ss
== gfc_ss_terminator
)
3861 gfc_conv_expr_reference (&argse
, arg
->expr
);
3863 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1, NULL
, NULL
);
3864 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3865 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3869 type
= gfc_typenode_for_spec (&expr
->ts
);
3870 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
3872 /* If this TRANSFER is nested in another TRANSFER, use a type
3873 that preserves all bits. */
3874 if (expr
->ts
.type
== BT_LOGICAL
)
3875 type
= gfc_get_int_type (expr
->ts
.kind
);
3878 if (expr
->ts
.type
== BT_CHARACTER
)
3880 ptr
= convert (build_pointer_type (type
), ptr
);
3881 gfc_init_se (&argse
, NULL
);
3882 gfc_conv_expr (&argse
, arg
->expr
);
3883 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3884 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3886 se
->string_length
= argse
.string_length
;
3891 tmpdecl
= gfc_create_var (type
, "transfer");
3892 moldsize
= size_in_bytes (type
);
3894 /* Use memcpy to do the transfer. */
3895 tmp
= build_fold_addr_expr (tmpdecl
);
3896 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
3897 fold_convert (pvoid_type_node
, tmp
),
3898 fold_convert (pvoid_type_node
, ptr
),
3900 gfc_add_expr_to_block (&se
->pre
, tmp
);
3907 /* Generate code for the ALLOCATED intrinsic.
3908 Generate inline code that directly check the address of the argument. */
3911 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
3913 gfc_actual_arglist
*arg1
;
3918 gfc_init_se (&arg1se
, NULL
);
3919 arg1
= expr
->value
.function
.actual
;
3920 ss1
= gfc_walk_expr (arg1
->expr
);
3921 arg1se
.descriptor_only
= 1;
3922 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3924 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3925 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3926 tmp
, fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
3927 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
3931 /* Generate code for the ASSOCIATED intrinsic.
3932 If both POINTER and TARGET are arrays, generate a call to library function
3933 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3934 In other cases, generate inline code that directly compare the address of
3935 POINTER with the address of TARGET. */
3938 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
3940 gfc_actual_arglist
*arg1
;
3941 gfc_actual_arglist
*arg2
;
3946 tree nonzero_charlen
;
3947 tree nonzero_arraylen
;
3950 gfc_init_se (&arg1se
, NULL
);
3951 gfc_init_se (&arg2se
, NULL
);
3952 arg1
= expr
->value
.function
.actual
;
3954 ss1
= gfc_walk_expr (arg1
->expr
);
3958 /* No optional target. */
3959 if (ss1
== gfc_ss_terminator
)
3961 /* A pointer to a scalar. */
3962 arg1se
.want_pointer
= 1;
3963 gfc_conv_expr (&arg1se
, arg1
->expr
);
3968 /* A pointer to an array. */
3969 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3970 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3972 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3973 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3974 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp2
,
3975 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
3980 /* An optional target. */
3981 ss2
= gfc_walk_expr (arg2
->expr
);
3983 nonzero_charlen
= NULL_TREE
;
3984 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
3985 nonzero_charlen
= fold_build2 (NE_EXPR
, boolean_type_node
,
3986 arg1
->expr
->ts
.cl
->backend_decl
,
3989 if (ss1
== gfc_ss_terminator
)
3991 /* A pointer to a scalar. */
3992 gcc_assert (ss2
== gfc_ss_terminator
);
3993 arg1se
.want_pointer
= 1;
3994 gfc_conv_expr (&arg1se
, arg1
->expr
);
3995 arg2se
.want_pointer
= 1;
3996 gfc_conv_expr (&arg2se
, arg2
->expr
);
3997 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3998 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3999 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4000 arg1se
.expr
, arg2se
.expr
);
4001 tmp2
= fold_build2 (NE_EXPR
, boolean_type_node
,
4002 arg1se
.expr
, null_pointer_node
);
4003 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4008 /* An array pointer of zero length is not associated if target is
4010 arg1se
.descriptor_only
= 1;
4011 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
4012 tmp
= gfc_conv_descriptor_stride (arg1se
.expr
,
4013 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
4014 nonzero_arraylen
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
4015 build_int_cst (TREE_TYPE (tmp
), 0));
4017 /* A pointer to an array, call library function _gfor_associated. */
4018 gcc_assert (ss2
!= gfc_ss_terminator
);
4019 arg1se
.want_pointer
= 1;
4020 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
4022 arg2se
.want_pointer
= 1;
4023 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
4024 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
4025 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
4026 se
->expr
= build_call_expr (gfor_fndecl_associated
, 2,
4027 arg1se
.expr
, arg2se
.expr
);
4028 se
->expr
= convert (boolean_type_node
, se
->expr
);
4029 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4030 se
->expr
, nonzero_arraylen
);
4033 /* If target is present zero character length pointers cannot
4035 if (nonzero_charlen
!= NULL_TREE
)
4036 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4037 se
->expr
, nonzero_charlen
);
4040 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4044 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4047 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
4051 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4052 se
->expr
= build_call_expr (gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
4053 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4057 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4060 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
4064 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4066 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4067 type
= gfc_get_int_type (4);
4068 arg
= build_fold_addr_expr (fold_convert (type
, arg
));
4070 /* Convert it to the required type. */
4071 type
= gfc_typenode_for_spec (&expr
->ts
);
4072 se
->expr
= build_call_expr (gfor_fndecl_si_kind
, 1, arg
);
4073 se
->expr
= fold_convert (type
, se
->expr
);
4077 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4080 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
4082 gfc_actual_arglist
*actual
;
4087 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4089 gfc_init_se (&argse
, se
);
4091 /* Pass a NULL pointer for an absent arg. */
4092 if (actual
->expr
== NULL
)
4093 argse
.expr
= null_pointer_node
;
4099 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4101 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4102 ts
.type
= BT_INTEGER
;
4103 ts
.kind
= gfc_c_int_kind
;
4104 gfc_convert_type (actual
->expr
, &ts
, 2);
4106 gfc_conv_expr_reference (&argse
, actual
->expr
);
4109 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4110 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4111 args
= gfc_chainon_list (args
, argse
.expr
);
4114 /* Convert it to the required type. */
4115 type
= gfc_typenode_for_spec (&expr
->ts
);
4116 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
4117 se
->expr
= fold_convert (type
, se
->expr
);
4121 /* Generate code for TRIM (A) intrinsic function. */
4124 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
4134 unsigned int num_args
;
4136 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4137 args
= (tree
*) alloca (sizeof (tree
) * num_args
);
4139 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4140 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
4141 len
= gfc_create_var (gfc_get_int_type (4), "len");
4143 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4144 args
[0] = build_fold_addr_expr (len
);
4147 if (expr
->ts
.kind
== 1)
4148 function
= gfor_fndecl_string_trim
;
4149 else if (expr
->ts
.kind
== 4)
4150 function
= gfor_fndecl_string_trim_char4
;
4154 fndecl
= build_addr (function
, current_function_decl
);
4155 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4157 gfc_add_expr_to_block (&se
->pre
, tmp
);
4159 /* Free the temporary afterwards, if necessary. */
4160 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4161 len
, build_int_cst (TREE_TYPE (len
), 0));
4162 tmp
= gfc_call_free (var
);
4163 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
4164 gfc_add_expr_to_block (&se
->post
, tmp
);
4167 se
->string_length
= len
;
4171 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
4174 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
4176 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
4177 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
4179 stmtblock_t block
, body
;
4182 /* We store in charsize the size of a character. */
4183 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
4184 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
4186 /* Get the arguments. */
4187 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4188 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
4190 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
4191 ncopies_type
= TREE_TYPE (ncopies
);
4193 /* Check that NCOPIES is not negative. */
4194 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
4195 build_int_cst (ncopies_type
, 0));
4196 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4197 "Argument NCOPIES of REPEAT intrinsic is negative "
4198 "(its value is %lld)",
4199 fold_convert (long_integer_type_node
, ncopies
));
4201 /* If the source length is zero, any non negative value of NCOPIES
4202 is valid, and nothing happens. */
4203 n
= gfc_create_var (ncopies_type
, "ncopies");
4204 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4205 build_int_cst (size_type_node
, 0));
4206 tmp
= fold_build3 (COND_EXPR
, ncopies_type
, cond
,
4207 build_int_cst (ncopies_type
, 0), ncopies
);
4208 gfc_add_modify (&se
->pre
, n
, tmp
);
4211 /* Check that ncopies is not too large: ncopies should be less than
4212 (or equal to) MAX / slen, where MAX is the maximal integer of
4213 the gfc_charlen_type_node type. If slen == 0, we need a special
4214 case to avoid the division by zero. */
4215 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4216 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
4217 max
= fold_build2 (TRUNC_DIV_EXPR
, size_type_node
,
4218 fold_convert (size_type_node
, max
), slen
);
4219 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
4220 ? size_type_node
: ncopies_type
;
4221 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
4222 fold_convert (largest
, ncopies
),
4223 fold_convert (largest
, max
));
4224 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
4225 build_int_cst (size_type_node
, 0));
4226 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
, boolean_false_node
,
4228 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
4229 "Argument NCOPIES of REPEAT intrinsic is too large");
4231 /* Compute the destination length. */
4232 dlen
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4233 fold_convert (gfc_charlen_type_node
, slen
),
4234 fold_convert (gfc_charlen_type_node
, ncopies
));
4235 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
4236 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
4238 /* Generate the code to do the repeat operation:
4239 for (i = 0; i < ncopies; i++)
4240 memmove (dest + (i * slen * size), src, slen*size); */
4241 gfc_start_block (&block
);
4242 count
= gfc_create_var (ncopies_type
, "count");
4243 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
4244 exit_label
= gfc_build_label_decl (NULL_TREE
);
4246 /* Start the loop body. */
4247 gfc_start_block (&body
);
4249 /* Exit the loop if count >= ncopies. */
4250 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, count
, ncopies
);
4251 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4252 TREE_USED (exit_label
) = 1;
4253 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
4254 build_empty_stmt ());
4255 gfc_add_expr_to_block (&body
, tmp
);
4257 /* Call memmove (dest + (i*slen*size), src, slen*size). */
4258 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4259 fold_convert (gfc_charlen_type_node
, slen
),
4260 fold_convert (gfc_charlen_type_node
, count
));
4261 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
4262 tmp
, fold_convert (gfc_charlen_type_node
, size
));
4263 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pvoid_type_node
,
4264 fold_convert (pvoid_type_node
, dest
),
4265 fold_convert (sizetype
, tmp
));
4266 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], 3, tmp
, src
,
4267 fold_build2 (MULT_EXPR
, size_type_node
, slen
,
4268 fold_convert (size_type_node
, size
)));
4269 gfc_add_expr_to_block (&body
, tmp
);
4271 /* Increment count. */
4272 tmp
= fold_build2 (PLUS_EXPR
, ncopies_type
,
4273 count
, build_int_cst (TREE_TYPE (count
), 1));
4274 gfc_add_modify (&body
, count
, tmp
);
4276 /* Build the loop. */
4277 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
4278 gfc_add_expr_to_block (&block
, tmp
);
4280 /* Add the exit label. */
4281 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4282 gfc_add_expr_to_block (&block
, tmp
);
4284 /* Finish the block. */
4285 tmp
= gfc_finish_block (&block
);
4286 gfc_add_expr_to_block (&se
->pre
, tmp
);
4288 /* Set the result value. */
4290 se
->string_length
= dlen
;
4294 /* Generate code for the IARGC intrinsic. */
4297 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
4303 /* Call the library function. This always returns an INTEGER(4). */
4304 fndecl
= gfor_fndecl_iargc
;
4305 tmp
= build_call_expr (fndecl
, 0);
4307 /* Convert it to the required type. */
4308 type
= gfc_typenode_for_spec (&expr
->ts
);
4309 tmp
= fold_convert (type
, tmp
);
4315 /* The loc intrinsic returns the address of its argument as
4316 gfc_index_integer_kind integer. */
4319 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
4325 gcc_assert (!se
->ss
);
4327 arg_expr
= expr
->value
.function
.actual
->expr
;
4328 ss
= gfc_walk_expr (arg_expr
);
4329 if (ss
== gfc_ss_terminator
)
4330 gfc_conv_expr_reference (se
, arg_expr
);
4332 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1, NULL
, NULL
);
4333 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
4335 /* Create a temporary variable for loc return value. Without this,
4336 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4337 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
4338 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
4339 se
->expr
= temp_var
;
4342 /* Generate code for an intrinsic function. Some map directly to library
4343 calls, others get special handling. In some cases the name of the function
4344 used depends on the type specifiers. */
4347 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
4349 gfc_intrinsic_sym
*isym
;
4354 isym
= expr
->value
.function
.isym
;
4356 name
= &expr
->value
.function
.name
[2];
4358 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
4360 lib
= gfc_is_intrinsic_libcall (expr
);
4364 se
->ignore_optional
= 1;
4366 switch (expr
->value
.function
.isym
->id
)
4368 case GFC_ISYM_EOSHIFT
:
4370 case GFC_ISYM_RESHAPE
:
4371 /* For all of those the first argument specifies the type and the
4372 third is optional. */
4373 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
4377 gfc_conv_intrinsic_funcall (se
, expr
);
4385 switch (expr
->value
.function
.isym
->id
)
4390 case GFC_ISYM_REPEAT
:
4391 gfc_conv_intrinsic_repeat (se
, expr
);
4395 gfc_conv_intrinsic_trim (se
, expr
);
4398 case GFC_ISYM_SC_KIND
:
4399 gfc_conv_intrinsic_sc_kind (se
, expr
);
4402 case GFC_ISYM_SI_KIND
:
4403 gfc_conv_intrinsic_si_kind (se
, expr
);
4406 case GFC_ISYM_SR_KIND
:
4407 gfc_conv_intrinsic_sr_kind (se
, expr
);
4410 case GFC_ISYM_EXPONENT
:
4411 gfc_conv_intrinsic_exponent (se
, expr
);
4415 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4417 fndecl
= gfor_fndecl_string_scan
;
4419 fndecl
= gfor_fndecl_string_scan_char4
;
4423 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4426 case GFC_ISYM_VERIFY
:
4427 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4429 fndecl
= gfor_fndecl_string_verify
;
4431 fndecl
= gfor_fndecl_string_verify_char4
;
4435 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4438 case GFC_ISYM_ALLOCATED
:
4439 gfc_conv_allocated (se
, expr
);
4442 case GFC_ISYM_ASSOCIATED
:
4443 gfc_conv_associated(se
, expr
);
4447 gfc_conv_intrinsic_abs (se
, expr
);
4450 case GFC_ISYM_ADJUSTL
:
4451 if (expr
->ts
.kind
== 1)
4452 fndecl
= gfor_fndecl_adjustl
;
4453 else if (expr
->ts
.kind
== 4)
4454 fndecl
= gfor_fndecl_adjustl_char4
;
4458 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
4461 case GFC_ISYM_ADJUSTR
:
4462 if (expr
->ts
.kind
== 1)
4463 fndecl
= gfor_fndecl_adjustr
;
4464 else if (expr
->ts
.kind
== 4)
4465 fndecl
= gfor_fndecl_adjustr_char4
;
4469 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
4472 case GFC_ISYM_AIMAG
:
4473 gfc_conv_intrinsic_imagpart (se
, expr
);
4477 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
4481 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
4484 case GFC_ISYM_ANINT
:
4485 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
4489 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
4493 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
4496 case GFC_ISYM_BTEST
:
4497 gfc_conv_intrinsic_btest (se
, expr
);
4500 case GFC_ISYM_ACHAR
:
4502 gfc_conv_intrinsic_char (se
, expr
);
4505 case GFC_ISYM_CONVERSION
:
4507 case GFC_ISYM_LOGICAL
:
4509 gfc_conv_intrinsic_conversion (se
, expr
);
4512 /* Integer conversions are handled separately to make sure we get the
4513 correct rounding mode. */
4518 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
4522 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
4525 case GFC_ISYM_CEILING
:
4526 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
4529 case GFC_ISYM_FLOOR
:
4530 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
4534 gfc_conv_intrinsic_mod (se
, expr
, 0);
4537 case GFC_ISYM_MODULO
:
4538 gfc_conv_intrinsic_mod (se
, expr
, 1);
4541 case GFC_ISYM_CMPLX
:
4542 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
4545 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
4546 gfc_conv_intrinsic_iargc (se
, expr
);
4549 case GFC_ISYM_COMPLEX
:
4550 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
4553 case GFC_ISYM_CONJG
:
4554 gfc_conv_intrinsic_conjg (se
, expr
);
4557 case GFC_ISYM_COUNT
:
4558 gfc_conv_intrinsic_count (se
, expr
);
4561 case GFC_ISYM_CTIME
:
4562 gfc_conv_intrinsic_ctime (se
, expr
);
4566 gfc_conv_intrinsic_dim (se
, expr
);
4569 case GFC_ISYM_DOT_PRODUCT
:
4570 gfc_conv_intrinsic_dot_product (se
, expr
);
4573 case GFC_ISYM_DPROD
:
4574 gfc_conv_intrinsic_dprod (se
, expr
);
4577 case GFC_ISYM_FDATE
:
4578 gfc_conv_intrinsic_fdate (se
, expr
);
4581 case GFC_ISYM_FRACTION
:
4582 gfc_conv_intrinsic_fraction (se
, expr
);
4586 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
4589 case GFC_ISYM_IBCLR
:
4590 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
4593 case GFC_ISYM_IBITS
:
4594 gfc_conv_intrinsic_ibits (se
, expr
);
4597 case GFC_ISYM_IBSET
:
4598 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
4601 case GFC_ISYM_IACHAR
:
4602 case GFC_ISYM_ICHAR
:
4603 /* We assume ASCII character sequence. */
4604 gfc_conv_intrinsic_ichar (se
, expr
);
4607 case GFC_ISYM_IARGC
:
4608 gfc_conv_intrinsic_iargc (se
, expr
);
4612 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4615 case GFC_ISYM_INDEX
:
4616 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4618 fndecl
= gfor_fndecl_string_index
;
4620 fndecl
= gfor_fndecl_string_index_char4
;
4624 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4628 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4631 case GFC_ISYM_IS_IOSTAT_END
:
4632 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
4635 case GFC_ISYM_IS_IOSTAT_EOR
:
4636 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
4639 case GFC_ISYM_ISNAN
:
4640 gfc_conv_intrinsic_isnan (se
, expr
);
4643 case GFC_ISYM_LSHIFT
:
4644 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
4647 case GFC_ISYM_RSHIFT
:
4648 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
4651 case GFC_ISYM_ISHFT
:
4652 gfc_conv_intrinsic_ishft (se
, expr
);
4655 case GFC_ISYM_ISHFTC
:
4656 gfc_conv_intrinsic_ishftc (se
, expr
);
4659 case GFC_ISYM_LEADZ
:
4660 gfc_conv_intrinsic_leadz (se
, expr
);
4663 case GFC_ISYM_TRAILZ
:
4664 gfc_conv_intrinsic_trailz (se
, expr
);
4667 case GFC_ISYM_LBOUND
:
4668 gfc_conv_intrinsic_bound (se
, expr
, 0);
4671 case GFC_ISYM_TRANSPOSE
:
4672 if (se
->ss
&& se
->ss
->useflags
)
4674 gfc_conv_tmp_array_ref (se
);
4675 gfc_advance_se_ss_chain (se
);
4678 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
4682 gfc_conv_intrinsic_len (se
, expr
);
4685 case GFC_ISYM_LEN_TRIM
:
4686 gfc_conv_intrinsic_len_trim (se
, expr
);
4690 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
4694 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
4698 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
4702 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
4706 if (expr
->ts
.type
== BT_CHARACTER
)
4707 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
4709 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
4712 case GFC_ISYM_MAXLOC
:
4713 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
4716 case GFC_ISYM_MAXVAL
:
4717 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
4720 case GFC_ISYM_MERGE
:
4721 gfc_conv_intrinsic_merge (se
, expr
);
4725 if (expr
->ts
.type
== BT_CHARACTER
)
4726 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
4728 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
4731 case GFC_ISYM_MINLOC
:
4732 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
4735 case GFC_ISYM_MINVAL
:
4736 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
4739 case GFC_ISYM_NEAREST
:
4740 gfc_conv_intrinsic_nearest (se
, expr
);
4744 gfc_conv_intrinsic_not (se
, expr
);
4748 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4751 case GFC_ISYM_PRESENT
:
4752 gfc_conv_intrinsic_present (se
, expr
);
4755 case GFC_ISYM_PRODUCT
:
4756 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
4759 case GFC_ISYM_RRSPACING
:
4760 gfc_conv_intrinsic_rrspacing (se
, expr
);
4763 case GFC_ISYM_SET_EXPONENT
:
4764 gfc_conv_intrinsic_set_exponent (se
, expr
);
4767 case GFC_ISYM_SCALE
:
4768 gfc_conv_intrinsic_scale (se
, expr
);
4772 gfc_conv_intrinsic_sign (se
, expr
);
4776 gfc_conv_intrinsic_size (se
, expr
);
4779 case GFC_ISYM_SIZEOF
:
4780 gfc_conv_intrinsic_sizeof (se
, expr
);
4783 case GFC_ISYM_SPACING
:
4784 gfc_conv_intrinsic_spacing (se
, expr
);
4788 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
4791 case GFC_ISYM_TRANSFER
:
4792 if (se
->ss
&& se
->ss
->useflags
)
4794 /* Access the previously obtained result. */
4795 gfc_conv_tmp_array_ref (se
);
4796 gfc_advance_se_ss_chain (se
);
4800 /* Ensure double transfer through LOGICAL preserves all
4802 gfc_expr
*source
= expr
->value
.function
.actual
->expr
;
4803 if (source
->expr_type
== EXPR_FUNCTION
4804 && source
->value
.function
.esym
== NULL
4805 && source
->value
.function
.isym
!= NULL
4806 && source
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
4807 && source
->ts
.type
== BT_LOGICAL
4808 && expr
->ts
.type
!= source
->ts
.type
)
4809 source
->value
.function
.name
= "__transfer_in_transfer";
4812 gfc_conv_intrinsic_array_transfer (se
, expr
);
4814 gfc_conv_intrinsic_transfer (se
, expr
);
4818 case GFC_ISYM_TTYNAM
:
4819 gfc_conv_intrinsic_ttynam (se
, expr
);
4822 case GFC_ISYM_UBOUND
:
4823 gfc_conv_intrinsic_bound (se
, expr
, 1);
4827 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4831 gfc_conv_intrinsic_loc (se
, expr
);
4834 case GFC_ISYM_ACCESS
:
4835 case GFC_ISYM_CHDIR
:
4836 case GFC_ISYM_CHMOD
:
4837 case GFC_ISYM_DTIME
:
4838 case GFC_ISYM_ETIME
:
4840 case GFC_ISYM_FGETC
:
4843 case GFC_ISYM_FPUTC
:
4844 case GFC_ISYM_FSTAT
:
4845 case GFC_ISYM_FTELL
:
4846 case GFC_ISYM_GETCWD
:
4847 case GFC_ISYM_GETGID
:
4848 case GFC_ISYM_GETPID
:
4849 case GFC_ISYM_GETUID
:
4850 case GFC_ISYM_HOSTNM
:
4852 case GFC_ISYM_IERRNO
:
4853 case GFC_ISYM_IRAND
:
4854 case GFC_ISYM_ISATTY
:
4856 case GFC_ISYM_LSTAT
:
4857 case GFC_ISYM_MALLOC
:
4858 case GFC_ISYM_MATMUL
:
4859 case GFC_ISYM_MCLOCK
:
4860 case GFC_ISYM_MCLOCK8
:
4862 case GFC_ISYM_RENAME
:
4863 case GFC_ISYM_SECOND
:
4864 case GFC_ISYM_SECNDS
:
4865 case GFC_ISYM_SIGNAL
:
4867 case GFC_ISYM_SYMLNK
:
4868 case GFC_ISYM_SYSTEM
:
4870 case GFC_ISYM_TIME8
:
4871 case GFC_ISYM_UMASK
:
4872 case GFC_ISYM_UNLINK
:
4873 gfc_conv_intrinsic_funcall (se
, expr
);
4876 case GFC_ISYM_EOSHIFT
:
4878 case GFC_ISYM_RESHAPE
:
4879 /* For those, expr->rank should always be >0 and thus the if above the
4880 switch should have matched. */
4885 gfc_conv_intrinsic_lib_function (se
, expr
);
4891 /* This generates code to execute before entering the scalarization loop.
4892 Currently does nothing. */
4895 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
4897 switch (ss
->expr
->value
.function
.isym
->id
)
4899 case GFC_ISYM_UBOUND
:
4900 case GFC_ISYM_LBOUND
:
4909 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4910 inside the scalarization loop. */
4913 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
4917 /* The two argument version returns a scalar. */
4918 if (expr
->value
.function
.actual
->next
->expr
)
4921 newss
= gfc_get_ss ();
4922 newss
->type
= GFC_SS_INTRINSIC
;
4925 newss
->data
.info
.dimen
= 1;
4931 /* Walk an intrinsic array libcall. */
4934 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
4938 gcc_assert (expr
->rank
> 0);
4940 newss
= gfc_get_ss ();
4941 newss
->type
= GFC_SS_FUNCTION
;
4944 newss
->data
.info
.dimen
= expr
->rank
;
4950 /* Returns nonzero if the specified intrinsic function call maps directly to
4951 an external library call. Should only be used for functions that return
4955 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
4957 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
4958 gcc_assert (expr
->rank
> 0);
4960 switch (expr
->value
.function
.isym
->id
)
4964 case GFC_ISYM_COUNT
:
4965 case GFC_ISYM_MATMUL
:
4966 case GFC_ISYM_MAXLOC
:
4967 case GFC_ISYM_MAXVAL
:
4968 case GFC_ISYM_MINLOC
:
4969 case GFC_ISYM_MINVAL
:
4970 case GFC_ISYM_PRODUCT
:
4972 case GFC_ISYM_SHAPE
:
4973 case GFC_ISYM_SPREAD
:
4974 case GFC_ISYM_TRANSPOSE
:
4975 /* Ignore absent optional parameters. */
4978 case GFC_ISYM_RESHAPE
:
4979 case GFC_ISYM_CSHIFT
:
4980 case GFC_ISYM_EOSHIFT
:
4982 case GFC_ISYM_UNPACK
:
4983 /* Pass absent optional parameters. */
4991 /* Walk an intrinsic function. */
4993 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
4994 gfc_intrinsic_sym
* isym
)
4998 if (isym
->elemental
)
4999 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
5001 if (expr
->rank
== 0)
5004 if (gfc_is_intrinsic_libcall (expr
))
5005 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5007 /* Special cases. */
5010 case GFC_ISYM_LBOUND
:
5011 case GFC_ISYM_UBOUND
:
5012 return gfc_walk_intrinsic_bound (ss
, expr
);
5014 case GFC_ISYM_TRANSFER
:
5015 return gfc_walk_intrinsic_libfunc (ss
, expr
);
5018 /* This probably meant someone forgot to add an intrinsic to the above
5019 list(s) when they implemented it, or something's gone horribly
5025 #include "gt-fortran-trans-intrinsic.h"