1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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 GTY(()) gfc_intrinsic_map_t {
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
53 /* Enum value from the "language-independent", aka C-centric, part
54 of gcc, or END_BUILTINS of no such value set. */
55 enum built_in_function code_r4;
56 enum built_in_function code_r8;
57 enum built_in_function code_r10;
58 enum built_in_function code_r16;
59 enum built_in_function code_c4;
60 enum built_in_function code_c8;
61 enum built_in_function code_c10;
62 enum built_in_function code_c16;
64 /* True if the naming pattern is to prepend "c" for complex and
65 append "f" for kind=4. False if the naming pattern is to
66 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
69 /* True if a complex version of the function exists. */
70 bool complex_available;
72 /* True if the function should be marked const. */
75 /* The base library name of this function. */
78 /* Cache decls created for the various operand types. */
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 defines complex variants of all of the entries in mathbuiltins.def
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, (enum built_in_function) 0, \
96 (enum built_in_function) 0, (enum built_in_function) 0, \
97 (enum built_in_function) 0, true, false, true, NAME, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
101 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
102 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
103 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
104 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
105 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
108 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
109 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
116 /* Functions built into gcc itself. */
117 #include "mathbuiltins.def"
119 /* Functions in libgfortran. */
120 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
123 LIB_FUNCTION (NONE, NULL, false)
127 #undef DEFINE_MATH_BUILTIN
128 #undef DEFINE_MATH_BUILTIN_C
130 /* Structure for storing components of a floating number to be used by
131 elemental functions to manipulate reals. */
134 tree arg; /* Variable tree to view convert to integer. */
135 tree expn; /* Variable tree to save exponent. */
136 tree frac; /* Variable tree to save fraction. */
137 tree smask; /* Constant tree of sign's mask. */
138 tree emask; /* Constant tree of exponent's mask. */
139 tree fmask; /* Constant tree of fraction's mask. */
140 tree edigits; /* Constant tree of the number of exponent bits. */
141 tree fdigits; /* Constant tree of the number of fraction bits. */
142 tree f1; /* Constant tree of the f1 defined in the real model. */
143 tree bias; /* Constant tree of the bias of exponent in the memory. */
144 tree type; /* Type tree of arg1. */
145 tree mtype; /* Type tree of integer type. Kind is that of arg1. */
149 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
151 /* Evaluate the arguments to an intrinsic function. The value
152 of NARGS may be less than the actual number of arguments in EXPR
153 to allow optional "KIND" arguments that are not included in the
154 generated code to be ignored. */
157 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
158 tree *argarray, int nargs)
160 gfc_actual_arglist *actual;
162 gfc_intrinsic_arg *formal;
166 formal = expr->value.function.isym->formal;
167 actual = expr->value.function.actual;
169 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
170 actual = actual->next,
171 formal = formal ? formal->next : NULL)
175 /* Skip omitted optional arguments. */
182 /* Evaluate the parameter. This will substitute scalarized
183 references automatically. */
184 gfc_init_se (&argse, se);
186 if (e->ts.type == BT_CHARACTER)
188 gfc_conv_expr (&argse, e);
189 gfc_conv_string_parameter (&argse);
190 argarray[curr_arg++] = argse.string_length;
191 gcc_assert (curr_arg < nargs);
194 gfc_conv_expr_val (&argse, e);
196 /* If an optional argument is itself an optional dummy argument,
197 check its presence and substitute a null if absent. */
198 if (e->expr_type == EXPR_VARIABLE
199 && e->symtree->n.sym->attr.optional
202 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
204 gfc_add_block_to_block (&se->pre, &argse.pre);
205 gfc_add_block_to_block (&se->post, &argse.post);
206 argarray[curr_arg] = argse.expr;
210 /* Count the number of actual arguments to the intrinsic function EXPR
211 including any "hidden" string length arguments. */
214 gfc_intrinsic_argument_list_length (gfc_expr *expr)
217 gfc_actual_arglist *actual;
219 for (actual = expr->value.function.actual; actual; actual = actual->next)
224 if (actual->expr->ts.type == BT_CHARACTER)
234 /* Conversions between different types are output by the frontend as
235 intrinsic functions. We implement these directly with inline code. */
238 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
244 nargs = gfc_intrinsic_argument_list_length (expr);
245 args = (tree *) alloca (sizeof (tree) * nargs);
247 /* Evaluate all the arguments passed. Whilst we're only interested in the
248 first one here, there are other parts of the front-end that assume this
249 and will trigger an ICE if it's not the case. */
250 type = gfc_typenode_for_spec (&expr->ts);
251 gcc_assert (expr->value.function.actual->expr);
252 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
254 /* Conversion between character kinds involves a call to a library
256 if (expr->ts.type == BT_CHARACTER)
258 tree fndecl, var, addr, tmp;
260 if (expr->ts.kind == 1
261 && expr->value.function.actual->expr->ts.kind == 4)
262 fndecl = gfor_fndecl_convert_char4_to_char1;
263 else if (expr->ts.kind == 4
264 && expr->value.function.actual->expr->ts.kind == 1)
265 fndecl = gfor_fndecl_convert_char1_to_char4;
269 /* Create the variable storing the converted value. */
270 type = gfc_get_pchar_type (expr->ts.kind);
271 var = gfc_create_var (type, "str");
272 addr = gfc_build_addr_expr (build_pointer_type (type), var);
274 /* Call the library function that will perform the conversion. */
275 gcc_assert (nargs >= 2);
276 tmp = build_call_expr_loc (input_location,
277 fndecl, 3, addr, args[0], args[1]);
278 gfc_add_expr_to_block (&se->pre, tmp);
280 /* Free the temporary afterwards. */
281 tmp = gfc_call_free (var);
282 gfc_add_expr_to_block (&se->post, tmp);
285 se->string_length = args[0];
290 /* Conversion from complex to non-complex involves taking the real
291 component of the value. */
292 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
293 && expr->ts.type != BT_COMPLEX)
297 artype = TREE_TYPE (TREE_TYPE (args[0]));
298 args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
301 se->expr = convert (type, args[0]);
304 /* This is needed because the gcc backend only implements
305 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
306 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
307 Similarly for CEILING. */
310 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
317 argtype = TREE_TYPE (arg);
318 arg = gfc_evaluate_now (arg, pblock);
320 intval = convert (type, arg);
321 intval = gfc_evaluate_now (intval, pblock);
323 tmp = convert (argtype, intval);
324 cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
326 tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
327 build_int_cst (type, 1));
328 tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
333 /* Round to nearest integer, away from zero. */
336 build_round_expr (tree arg, tree restype)
341 int argprec, resprec;
343 argtype = TREE_TYPE (arg);
344 argprec = TYPE_PRECISION (argtype);
345 resprec = TYPE_PRECISION (restype);
347 /* Depending on the type of the result, choose the long int intrinsic
348 (lround family) or long long intrinsic (llround). We might also
349 need to convert the result afterwards. */
350 if (resprec <= LONG_TYPE_SIZE)
352 else if (resprec <= LONG_LONG_TYPE_SIZE)
357 /* Now, depending on the argument type, we choose between intrinsics. */
358 if (argprec == TYPE_PRECISION (float_type_node))
359 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
360 else if (argprec == TYPE_PRECISION (double_type_node))
361 fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
362 else if (argprec == TYPE_PRECISION (long_double_type_node))
363 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
367 return fold_convert (restype, build_call_expr_loc (input_location,
372 /* Convert a real to an integer using a specific rounding mode.
373 Ideally we would just build the corresponding GENERIC node,
374 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
377 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
378 enum rounding_mode op)
383 return build_fixbound_expr (pblock, arg, type, 0);
387 return build_fixbound_expr (pblock, arg, type, 1);
391 return build_round_expr (arg, type);
395 return fold_build1 (FIX_TRUNC_EXPR, type, arg);
404 /* Round a real value using the specified rounding mode.
405 We use a temporary integer of that same kind size as the result.
406 Values larger than those that can be represented by this kind are
407 unchanged, as they will not be accurate enough to represent the
409 huge = HUGE (KIND (a))
410 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
414 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
425 kind = expr->ts.kind;
426 nargs = gfc_intrinsic_argument_list_length (expr);
429 /* We have builtin functions for some cases. */
472 /* Evaluate the argument. */
473 gcc_assert (expr->value.function.actual->expr);
474 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
476 /* Use a builtin function if one exists. */
477 if (n != END_BUILTINS)
479 tmp = built_in_decls[n];
480 se->expr = build_call_expr_loc (input_location,
485 /* This code is probably redundant, but we'll keep it lying around just
487 type = gfc_typenode_for_spec (&expr->ts);
488 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
490 /* Test if the value is too large to handle sensibly. */
491 gfc_set_model_kind (kind);
493 n = gfc_validate_kind (BT_INTEGER, kind, false);
494 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
495 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
496 cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
498 mpfr_neg (huge, huge, GFC_RND_MODE);
499 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
500 tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
501 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
502 itype = gfc_get_int_type (kind);
504 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
505 tmp = convert (type, tmp);
506 se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
511 /* Convert to an integer using the specified rounding mode. */
514 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
520 nargs = gfc_intrinsic_argument_list_length (expr);
521 args = (tree *) alloca (sizeof (tree) * nargs);
523 /* Evaluate the argument, we process all arguments even though we only
524 use the first one for code generation purposes. */
525 type = gfc_typenode_for_spec (&expr->ts);
526 gcc_assert (expr->value.function.actual->expr);
527 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
529 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
531 /* Conversion to a different integer kind. */
532 se->expr = convert (type, args[0]);
536 /* Conversion from complex to non-complex involves taking the real
537 component of the value. */
538 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
539 && expr->ts.type != BT_COMPLEX)
543 artype = TREE_TYPE (TREE_TYPE (args[0]));
544 args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
547 se->expr = build_fix_expr (&se->pre, args[0], type, op);
552 /* Get the imaginary component of a value. */
555 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
559 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
560 se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
564 /* Get the complex conjugate of a value. */
567 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
571 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
572 se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
576 /* Initialize function decls for library functions. The external functions
577 are created as required. Builtin functions are added here. */
580 gfc_build_intrinsic_lib_fndecls (void)
582 gfc_intrinsic_map_t *m;
584 /* Add GCC builtin functions. */
585 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
587 if (m->code_r4 != END_BUILTINS)
588 m->real4_decl = built_in_decls[m->code_r4];
589 if (m->code_r8 != END_BUILTINS)
590 m->real8_decl = built_in_decls[m->code_r8];
591 if (m->code_r10 != END_BUILTINS)
592 m->real10_decl = built_in_decls[m->code_r10];
593 if (m->code_r16 != END_BUILTINS)
594 m->real16_decl = built_in_decls[m->code_r16];
595 if (m->code_c4 != END_BUILTINS)
596 m->complex4_decl = built_in_decls[m->code_c4];
597 if (m->code_c8 != END_BUILTINS)
598 m->complex8_decl = built_in_decls[m->code_c8];
599 if (m->code_c10 != END_BUILTINS)
600 m->complex10_decl = built_in_decls[m->code_c10];
601 if (m->code_c16 != END_BUILTINS)
602 m->complex16_decl = built_in_decls[m->code_c16];
607 /* Create a fndecl for a simple intrinsic library function. */
610 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
615 gfc_actual_arglist *actual;
618 char name[GFC_MAX_SYMBOL_LEN + 3];
621 if (ts->type == BT_REAL)
626 pdecl = &m->real4_decl;
629 pdecl = &m->real8_decl;
632 pdecl = &m->real10_decl;
635 pdecl = &m->real16_decl;
641 else if (ts->type == BT_COMPLEX)
643 gcc_assert (m->complex_available);
648 pdecl = &m->complex4_decl;
651 pdecl = &m->complex8_decl;
654 pdecl = &m->complex10_decl;
657 pdecl = &m->complex16_decl;
672 snprintf (name, sizeof (name), "%s%s%s",
673 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
674 else if (ts->kind == 8)
675 snprintf (name, sizeof (name), "%s%s",
676 ts->type == BT_COMPLEX ? "c" : "", m->name);
679 gcc_assert (ts->kind == 10 || ts->kind == 16);
680 snprintf (name, sizeof (name), "%s%s%s",
681 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
686 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
687 ts->type == BT_COMPLEX ? 'c' : 'r',
691 argtypes = NULL_TREE;
692 for (actual = expr->value.function.actual; actual; actual = actual->next)
694 type = gfc_typenode_for_spec (&actual->expr->ts);
695 argtypes = gfc_chainon_list (argtypes, type);
697 argtypes = gfc_chainon_list (argtypes, void_type_node);
698 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
699 fndecl = build_decl (input_location,
700 FUNCTION_DECL, get_identifier (name), type);
702 /* Mark the decl as external. */
703 DECL_EXTERNAL (fndecl) = 1;
704 TREE_PUBLIC (fndecl) = 1;
706 /* Mark it __attribute__((const)), if possible. */
707 TREE_READONLY (fndecl) = m->is_constant;
709 rest_of_decl_compilation (fndecl, 1, 0);
716 /* Convert an intrinsic function into an external or builtin call. */
719 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
721 gfc_intrinsic_map_t *m;
725 unsigned int num_args;
728 id = expr->value.function.isym->id;
729 /* Find the entry for this function. */
730 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
736 if (m->id == GFC_ISYM_NONE)
738 internal_error ("Intrinsic function %s(%d) not recognized",
739 expr->value.function.name, id);
742 /* Get the decl and generate the call. */
743 num_args = gfc_intrinsic_argument_list_length (expr);
744 args = (tree *) alloca (sizeof (tree) * num_args);
746 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
747 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
748 rettype = TREE_TYPE (TREE_TYPE (fndecl));
750 fndecl = build_addr (fndecl, current_function_decl);
751 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
755 /* If bounds-checking is enabled, create code to verify at runtime that the
756 string lengths for both expressions are the same (needed for e.g. MERGE).
757 If bounds-checking is not enabled, does nothing. */
760 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
761 tree a, tree b, stmtblock_t* target)
766 /* If bounds-checking is disabled, do nothing. */
767 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
770 /* Compare the two string lengths. */
771 cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
773 /* Output the runtime-check. */
774 name = gfc_build_cstring_const (intr_name);
775 name = gfc_build_addr_expr (pchar_type_node, name);
776 gfc_trans_runtime_check (true, false, cond, target, where,
777 "Unequal character lengths (%ld/%ld) in %s",
778 fold_convert (long_integer_type_node, a),
779 fold_convert (long_integer_type_node, b), name);
783 /* The EXPONENT(s) intrinsic function is translated into
790 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
792 tree arg, type, res, tmp;
795 switch (expr->value.function.actual->expr->ts.kind)
798 frexp = BUILT_IN_FREXPF;
801 frexp = BUILT_IN_FREXP;
805 frexp = BUILT_IN_FREXPL;
811 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
813 res = gfc_create_var (integer_type_node, NULL);
814 tmp = build_call_expr_loc (input_location,
815 built_in_decls[frexp], 2, arg,
816 gfc_build_addr_expr (NULL_TREE, res));
817 gfc_add_expr_to_block (&se->pre, tmp);
819 type = gfc_typenode_for_spec (&expr->ts);
820 se->expr = fold_convert (type, res);
823 /* Evaluate a single upper or lower bound. */
824 /* TODO: bound intrinsic generates way too much unnecessary code. */
827 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
829 gfc_actual_arglist *arg;
830 gfc_actual_arglist *arg2;
835 tree cond, cond1, cond2, cond3, cond4, size;
843 arg = expr->value.function.actual;
848 /* Create an implicit second parameter from the loop variable. */
849 gcc_assert (!arg2->expr);
850 gcc_assert (se->loop->dimen == 1);
851 gcc_assert (se->ss->expr == expr);
852 gfc_advance_se_ss_chain (se);
853 bound = se->loop->loopvar[0];
854 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
859 /* use the passed argument. */
860 gcc_assert (arg->next->expr);
861 gfc_init_se (&argse, NULL);
862 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
863 gfc_add_block_to_block (&se->pre, &argse.pre);
865 /* Convert from one based to zero based. */
866 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
870 /* TODO: don't re-evaluate the descriptor on each iteration. */
871 /* Get a descriptor for the first parameter. */
872 ss = gfc_walk_expr (arg->expr);
873 gcc_assert (ss != gfc_ss_terminator);
874 gfc_init_se (&argse, NULL);
875 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
876 gfc_add_block_to_block (&se->pre, &argse.pre);
877 gfc_add_block_to_block (&se->post, &argse.post);
881 if (INTEGER_CST_P (bound))
885 hi = TREE_INT_CST_HIGH (bound);
886 low = TREE_INT_CST_LOW (bound);
887 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
888 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
889 "dimension index", upper ? "UBOUND" : "LBOUND",
894 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
896 bound = gfc_evaluate_now (bound, &se->pre);
897 cond = fold_build2 (LT_EXPR, boolean_type_node,
898 bound, build_int_cst (TREE_TYPE (bound), 0));
899 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
900 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
901 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
902 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
907 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
908 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
910 /* Follow any component references. */
911 if (arg->expr->expr_type == EXPR_VARIABLE
912 || arg->expr->expr_type == EXPR_CONSTANT)
914 as = arg->expr->symtree->n.sym->as;
915 for (ref = arg->expr->ref; ref; ref = ref->next)
920 as = ref->u.c.component->as;
928 switch (ref->u.ar.type)
947 /* 13.14.53: Result value for LBOUND
949 Case (i): For an array section or for an array expression other than a
950 whole array or array structure component, LBOUND(ARRAY, DIM)
951 has the value 1. For a whole array or array structure
952 component, LBOUND(ARRAY, DIM) has the value:
953 (a) equal to the lower bound for subscript DIM of ARRAY if
954 dimension DIM of ARRAY does not have extent zero
955 or if ARRAY is an assumed-size array of rank DIM,
958 13.14.113: Result value for UBOUND
960 Case (i): For an array section or for an array expression other than a
961 whole array or array structure component, UBOUND(ARRAY, DIM)
962 has the value equal to the number of elements in the given
963 dimension; otherwise, it has a value equal to the upper bound
964 for subscript DIM of ARRAY if dimension DIM of ARRAY does
965 not have size zero and has value zero if dimension DIM has
970 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
972 cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
973 cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
975 cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
976 gfc_index_zero_node);
977 cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
979 cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
980 gfc_index_zero_node);
985 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
987 cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
988 cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
990 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
992 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
993 ubound, gfc_index_zero_node);
997 if (as->type == AS_ASSUMED_SIZE)
998 cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
999 build_int_cst (TREE_TYPE (bound),
1000 arg->expr->rank - 1));
1002 cond = boolean_false_node;
1004 cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
1005 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
1007 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1008 lbound, gfc_index_one_node);
1015 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
1016 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
1017 gfc_index_one_node);
1018 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
1019 gfc_index_zero_node);
1022 se->expr = gfc_index_one_node;
1025 type = gfc_typenode_for_spec (&expr->ts);
1026 se->expr = convert (type, se->expr);
1031 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1036 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1038 switch (expr->value.function.actual->expr->ts.type)
1042 se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1046 switch (expr->ts.kind)
1061 se->expr = build_call_expr_loc (input_location,
1062 built_in_decls[n], 1, arg);
1071 /* Create a complex value from one or two real components. */
1074 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1080 unsigned int num_args;
1082 num_args = gfc_intrinsic_argument_list_length (expr);
1083 args = (tree *) alloca (sizeof (tree) * num_args);
1085 type = gfc_typenode_for_spec (&expr->ts);
1086 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1087 real = convert (TREE_TYPE (type), args[0]);
1089 imag = convert (TREE_TYPE (type), args[1]);
1090 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1092 imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1094 imag = convert (TREE_TYPE (type), imag);
1097 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1099 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1102 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1103 MODULO(A, P) = A - FLOOR (A / P) * P */
1104 /* TODO: MOD(x, 0) */
1107 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1118 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1120 switch (expr->ts.type)
1123 /* Integer case is easy, we've got a builtin op. */
1124 type = TREE_TYPE (args[0]);
1127 se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1129 se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1134 /* Check if we have a builtin fmod. */
1135 switch (expr->ts.kind)
1154 /* Use it if it exists. */
1155 if (n != END_BUILTINS)
1157 tmp = build_addr (built_in_decls[n], current_function_decl);
1158 se->expr = build_call_array_loc (input_location,
1159 TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1165 type = TREE_TYPE (args[0]);
1167 args[0] = gfc_evaluate_now (args[0], &se->pre);
1168 args[1] = gfc_evaluate_now (args[1], &se->pre);
1171 modulo = arg - floor (arg/arg2) * arg2, so
1172 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1174 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1175 thereby avoiding another division and retaining the accuracy
1176 of the builtin function. */
1177 if (n != END_BUILTINS && modulo)
1179 tree zero = gfc_build_const (type, integer_zero_node);
1180 tmp = gfc_evaluate_now (se->expr, &se->pre);
1181 test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1182 test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1183 test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1184 test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1185 test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1186 test = gfc_evaluate_now (test, &se->pre);
1187 se->expr = fold_build3 (COND_EXPR, type, test,
1188 fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1193 /* If we do not have a built_in fmod, the calculation is going to
1194 have to be done longhand. */
1195 tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1197 /* Test if the value is too large to handle sensibly. */
1198 gfc_set_model_kind (expr->ts.kind);
1200 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1201 ikind = expr->ts.kind;
1204 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1205 ikind = gfc_max_integer_kind;
1207 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1208 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1209 test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1211 mpfr_neg (huge, huge, GFC_RND_MODE);
1212 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1213 test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1214 test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1216 itype = gfc_get_int_type (ikind);
1218 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1220 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1221 tmp = convert (type, tmp);
1222 tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1223 tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1224 se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1233 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1236 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1244 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1245 type = TREE_TYPE (args[0]);
1247 val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1248 val = gfc_evaluate_now (val, &se->pre);
1250 zero = gfc_build_const (type, integer_zero_node);
1251 tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1252 se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1256 /* SIGN(A, B) is absolute value of A times sign of B.
1257 The real value versions use library functions to ensure the correct
1258 handling of negative zero. Integer case implemented as:
1259 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1263 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1269 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1270 if (expr->ts.type == BT_REAL)
1274 switch (expr->ts.kind)
1277 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1278 abs = built_in_decls[BUILT_IN_FABSF];
1281 tmp = built_in_decls[BUILT_IN_COPYSIGN];
1282 abs = built_in_decls[BUILT_IN_FABS];
1286 tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1287 abs = built_in_decls[BUILT_IN_FABSL];
1293 /* We explicitly have to ignore the minus sign. We do so by using
1294 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1295 if (!gfc_option.flag_sign_zero
1296 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1299 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1300 cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
1301 se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
1302 build_call_expr (abs, 1, args[0]),
1303 build_call_expr (tmp, 2, args[0], args[1]));
1306 se->expr = build_call_expr_loc (input_location,
1307 tmp, 2, args[0], args[1]);
1311 /* Having excluded floating point types, we know we are now dealing
1312 with signed integer types. */
1313 type = TREE_TYPE (args[0]);
1315 /* Args[0] is used multiple times below. */
1316 args[0] = gfc_evaluate_now (args[0], &se->pre);
1318 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1319 the signs of A and B are the same, and of all ones if they differ. */
1320 tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1321 tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1322 build_int_cst (type, TYPE_PRECISION (type) - 1));
1323 tmp = gfc_evaluate_now (tmp, &se->pre);
1325 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1326 is all ones (i.e. -1). */
1327 se->expr = fold_build2 (BIT_XOR_EXPR, type,
1328 fold_build2 (PLUS_EXPR, type, args[0], tmp),
1333 /* Test for the presence of an optional argument. */
1336 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1340 arg = expr->value.function.actual->expr;
1341 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1342 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1343 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1347 /* Calculate the double precision product of two single precision values. */
1350 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1355 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1357 /* Convert the args to double precision before multiplying. */
1358 type = gfc_typenode_for_spec (&expr->ts);
1359 args[0] = convert (type, args[0]);
1360 args[1] = convert (type, args[1]);
1361 se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1365 /* Return a length one character string containing an ascii character. */
1368 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1373 unsigned int num_args;
1375 num_args = gfc_intrinsic_argument_list_length (expr);
1376 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1378 type = gfc_get_char_type (expr->ts.kind);
1379 var = gfc_create_var (type, "char");
1381 arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1382 gfc_add_modify (&se->pre, var, arg[0]);
1383 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1384 se->string_length = integer_one_node;
1389 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1397 unsigned int num_args;
1399 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1400 args = (tree *) alloca (sizeof (tree) * num_args);
1402 var = gfc_create_var (pchar_type_node, "pstr");
1403 len = gfc_create_var (gfc_get_int_type (8), "len");
1405 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1406 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1407 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1409 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1410 tmp = build_call_array_loc (input_location,
1411 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1412 fndecl, num_args, args);
1413 gfc_add_expr_to_block (&se->pre, tmp);
1415 /* Free the temporary afterwards, if necessary. */
1416 cond = fold_build2 (GT_EXPR, boolean_type_node,
1417 len, build_int_cst (TREE_TYPE (len), 0));
1418 tmp = gfc_call_free (var);
1419 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1420 gfc_add_expr_to_block (&se->post, tmp);
1423 se->string_length = len;
1428 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1436 unsigned int num_args;
1438 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1439 args = (tree *) alloca (sizeof (tree) * num_args);
1441 var = gfc_create_var (pchar_type_node, "pstr");
1442 len = gfc_create_var (gfc_get_int_type (4), "len");
1444 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1445 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1446 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1448 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1449 tmp = build_call_array_loc (input_location,
1450 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1451 fndecl, num_args, args);
1452 gfc_add_expr_to_block (&se->pre, tmp);
1454 /* Free the temporary afterwards, if necessary. */
1455 cond = fold_build2 (GT_EXPR, boolean_type_node,
1456 len, build_int_cst (TREE_TYPE (len), 0));
1457 tmp = gfc_call_free (var);
1458 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1459 gfc_add_expr_to_block (&se->post, tmp);
1462 se->string_length = len;
1466 /* Return a character string containing the tty name. */
1469 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1477 unsigned int num_args;
1479 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1480 args = (tree *) alloca (sizeof (tree) * num_args);
1482 var = gfc_create_var (pchar_type_node, "pstr");
1483 len = gfc_create_var (gfc_get_int_type (4), "len");
1485 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1486 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1487 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1489 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1490 tmp = build_call_array_loc (input_location,
1491 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1492 fndecl, num_args, args);
1493 gfc_add_expr_to_block (&se->pre, tmp);
1495 /* Free the temporary afterwards, if necessary. */
1496 cond = fold_build2 (GT_EXPR, boolean_type_node,
1497 len, build_int_cst (TREE_TYPE (len), 0));
1498 tmp = gfc_call_free (var);
1499 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1500 gfc_add_expr_to_block (&se->post, tmp);
1503 se->string_length = len;
1507 /* Get the minimum/maximum value of all the parameters.
1508 minmax (a1, a2, a3, ...)
1511 if (a2 .op. mvar || isnan(mvar))
1513 if (a3 .op. mvar || isnan(mvar))
1520 /* TODO: Mismatching types can occur when specific names are used.
1521 These should be handled during resolution. */
1523 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1531 gfc_actual_arglist *argexpr;
1532 unsigned int i, nargs;
1534 nargs = gfc_intrinsic_argument_list_length (expr);
1535 args = (tree *) alloca (sizeof (tree) * nargs);
1537 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1538 type = gfc_typenode_for_spec (&expr->ts);
1540 argexpr = expr->value.function.actual;
1541 if (TREE_TYPE (args[0]) != type)
1542 args[0] = convert (type, args[0]);
1543 /* Only evaluate the argument once. */
1544 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1545 args[0] = gfc_evaluate_now (args[0], &se->pre);
1547 mvar = gfc_create_var (type, "M");
1548 gfc_add_modify (&se->pre, mvar, args[0]);
1549 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1555 /* Handle absent optional arguments by ignoring the comparison. */
1556 if (argexpr->expr->expr_type == EXPR_VARIABLE
1557 && argexpr->expr->symtree->n.sym->attr.optional
1558 && TREE_CODE (val) == INDIRECT_REF)
1559 cond = fold_build2_loc (input_location,
1560 NE_EXPR, boolean_type_node,
1561 TREE_OPERAND (val, 0),
1562 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1567 /* Only evaluate the argument once. */
1568 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1569 val = gfc_evaluate_now (val, &se->pre);
1572 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1574 tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1576 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1577 __builtin_isnan might be made dependent on that module being loaded,
1578 to help performance of programs that don't rely on IEEE semantics. */
1579 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1581 isnan = build_call_expr_loc (input_location,
1582 built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1583 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1584 fold_convert (boolean_type_node, isnan));
1586 tmp = build3_v (COND_EXPR, tmp, thencase,
1587 build_empty_stmt (input_location));
1589 if (cond != NULL_TREE)
1590 tmp = build3_v (COND_EXPR, cond, tmp,
1591 build_empty_stmt (input_location));
1593 gfc_add_expr_to_block (&se->pre, tmp);
1594 argexpr = argexpr->next;
1600 /* Generate library calls for MIN and MAX intrinsics for character
1603 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1606 tree var, len, fndecl, tmp, cond, function;
1609 nargs = gfc_intrinsic_argument_list_length (expr);
1610 args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1611 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1613 /* Create the result variables. */
1614 len = gfc_create_var (gfc_charlen_type_node, "len");
1615 args[0] = gfc_build_addr_expr (NULL_TREE, len);
1616 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1617 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1618 args[2] = build_int_cst (NULL_TREE, op);
1619 args[3] = build_int_cst (NULL_TREE, nargs / 2);
1621 if (expr->ts.kind == 1)
1622 function = gfor_fndecl_string_minmax;
1623 else if (expr->ts.kind == 4)
1624 function = gfor_fndecl_string_minmax_char4;
1628 /* Make the function call. */
1629 fndecl = build_addr (function, current_function_decl);
1630 tmp = build_call_array_loc (input_location,
1631 TREE_TYPE (TREE_TYPE (function)), fndecl,
1633 gfc_add_expr_to_block (&se->pre, tmp);
1635 /* Free the temporary afterwards, if necessary. */
1636 cond = fold_build2 (GT_EXPR, boolean_type_node,
1637 len, build_int_cst (TREE_TYPE (len), 0));
1638 tmp = gfc_call_free (var);
1639 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1640 gfc_add_expr_to_block (&se->post, tmp);
1643 se->string_length = len;
1647 /* Create a symbol node for this intrinsic. The symbol from the frontend
1648 has the generic name. */
1651 gfc_get_symbol_for_expr (gfc_expr * expr)
1655 /* TODO: Add symbols for intrinsic function to the global namespace. */
1656 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1657 sym = gfc_new_symbol (expr->value.function.name, NULL);
1660 sym->attr.external = 1;
1661 sym->attr.function = 1;
1662 sym->attr.always_explicit = 1;
1663 sym->attr.proc = PROC_INTRINSIC;
1664 sym->attr.flavor = FL_PROCEDURE;
1668 sym->attr.dimension = 1;
1669 sym->as = gfc_get_array_spec ();
1670 sym->as->type = AS_ASSUMED_SHAPE;
1671 sym->as->rank = expr->rank;
1674 /* TODO: proper argument lists for external intrinsics. */
1678 /* Generate a call to an external intrinsic function. */
1680 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1685 gcc_assert (!se->ss || se->ss->expr == expr);
1688 gcc_assert (expr->rank > 0);
1690 gcc_assert (expr->rank == 0);
1692 sym = gfc_get_symbol_for_expr (expr);
1694 /* Calls to libgfortran_matmul need to be appended special arguments,
1695 to be able to call the BLAS ?gemm functions if required and possible. */
1696 append_args = NULL_TREE;
1697 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1698 && sym->ts.type != BT_LOGICAL)
1700 tree cint = gfc_get_int_type (gfc_c_int_kind);
1702 if (gfc_option.flag_external_blas
1703 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1704 && (sym->ts.kind == gfc_default_real_kind
1705 || sym->ts.kind == gfc_default_double_kind))
1709 if (sym->ts.type == BT_REAL)
1711 if (sym->ts.kind == gfc_default_real_kind)
1712 gemm_fndecl = gfor_fndecl_sgemm;
1714 gemm_fndecl = gfor_fndecl_dgemm;
1718 if (sym->ts.kind == gfc_default_real_kind)
1719 gemm_fndecl = gfor_fndecl_cgemm;
1721 gemm_fndecl = gfor_fndecl_zgemm;
1724 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1725 append_args = gfc_chainon_list
1726 (append_args, build_int_cst
1727 (cint, gfc_option.blas_matmul_limit));
1728 append_args = gfc_chainon_list (append_args,
1729 gfc_build_addr_expr (NULL_TREE,
1734 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1735 append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1736 append_args = gfc_chainon_list (append_args, null_pointer_node);
1740 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1745 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1765 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1774 gfc_actual_arglist *actual;
1781 gfc_conv_intrinsic_funcall (se, expr);
1785 actual = expr->value.function.actual;
1786 type = gfc_typenode_for_spec (&expr->ts);
1787 /* Initialize the result. */
1788 resvar = gfc_create_var (type, "test");
1790 tmp = convert (type, boolean_true_node);
1792 tmp = convert (type, boolean_false_node);
1793 gfc_add_modify (&se->pre, resvar, tmp);
1795 /* Walk the arguments. */
1796 arrayss = gfc_walk_expr (actual->expr);
1797 gcc_assert (arrayss != gfc_ss_terminator);
1799 /* Initialize the scalarizer. */
1800 gfc_init_loopinfo (&loop);
1801 exit_label = gfc_build_label_decl (NULL_TREE);
1802 TREE_USED (exit_label) = 1;
1803 gfc_add_ss_to_loop (&loop, arrayss);
1805 /* Initialize the loop. */
1806 gfc_conv_ss_startstride (&loop);
1807 gfc_conv_loop_setup (&loop, &expr->where);
1809 gfc_mark_ss_chain_used (arrayss, 1);
1810 /* Generate the loop body. */
1811 gfc_start_scalarized_body (&loop, &body);
1813 /* If the condition matches then set the return value. */
1814 gfc_start_block (&block);
1816 tmp = convert (type, boolean_false_node);
1818 tmp = convert (type, boolean_true_node);
1819 gfc_add_modify (&block, resvar, tmp);
1821 /* And break out of the loop. */
1822 tmp = build1_v (GOTO_EXPR, exit_label);
1823 gfc_add_expr_to_block (&block, tmp);
1825 found = gfc_finish_block (&block);
1827 /* Check this element. */
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);
1833 gfc_add_block_to_block (&body, &arrayse.pre);
1834 tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1835 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1836 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1837 gfc_add_expr_to_block (&body, tmp);
1838 gfc_add_block_to_block (&body, &arrayse.post);
1840 gfc_trans_scalarizing_loops (&loop, &body);
1842 /* Add the exit label. */
1843 tmp = build1_v (LABEL_EXPR, exit_label);
1844 gfc_add_expr_to_block (&loop.pre, tmp);
1846 gfc_add_block_to_block (&se->pre, &loop.pre);
1847 gfc_add_block_to_block (&se->pre, &loop.post);
1848 gfc_cleanup_loop (&loop);
1853 /* COUNT(A) = Number of true elements in A. */
1855 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1862 gfc_actual_arglist *actual;
1868 gfc_conv_intrinsic_funcall (se, expr);
1872 actual = expr->value.function.actual;
1874 type = gfc_typenode_for_spec (&expr->ts);
1875 /* Initialize the result. */
1876 resvar = gfc_create_var (type, "count");
1877 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1879 /* Walk the arguments. */
1880 arrayss = gfc_walk_expr (actual->expr);
1881 gcc_assert (arrayss != gfc_ss_terminator);
1883 /* Initialize the scalarizer. */
1884 gfc_init_loopinfo (&loop);
1885 gfc_add_ss_to_loop (&loop, arrayss);
1887 /* Initialize the loop. */
1888 gfc_conv_ss_startstride (&loop);
1889 gfc_conv_loop_setup (&loop, &expr->where);
1891 gfc_mark_ss_chain_used (arrayss, 1);
1892 /* Generate the loop body. */
1893 gfc_start_scalarized_body (&loop, &body);
1895 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1896 resvar, build_int_cst (TREE_TYPE (resvar), 1));
1897 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1899 gfc_init_se (&arrayse, NULL);
1900 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1901 arrayse.ss = arrayss;
1902 gfc_conv_expr_val (&arrayse, actual->expr);
1903 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1904 build_empty_stmt (input_location));
1906 gfc_add_block_to_block (&body, &arrayse.pre);
1907 gfc_add_expr_to_block (&body, tmp);
1908 gfc_add_block_to_block (&body, &arrayse.post);
1910 gfc_trans_scalarizing_loops (&loop, &body);
1912 gfc_add_block_to_block (&se->pre, &loop.pre);
1913 gfc_add_block_to_block (&se->pre, &loop.post);
1914 gfc_cleanup_loop (&loop);
1919 /* Inline implementation of the sum and product intrinsics. */
1921 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
1929 gfc_actual_arglist *actual;
1934 gfc_expr *arrayexpr;
1939 gfc_conv_intrinsic_funcall (se, expr);
1943 type = gfc_typenode_for_spec (&expr->ts);
1944 /* Initialize the result. */
1945 resvar = gfc_create_var (type, "val");
1946 if (op == PLUS_EXPR)
1947 tmp = gfc_build_const (type, integer_zero_node);
1949 tmp = gfc_build_const (type, integer_one_node);
1951 gfc_add_modify (&se->pre, resvar, tmp);
1953 /* Walk the arguments. */
1954 actual = expr->value.function.actual;
1955 arrayexpr = actual->expr;
1956 arrayss = gfc_walk_expr (arrayexpr);
1957 gcc_assert (arrayss != gfc_ss_terminator);
1959 actual = actual->next->next;
1960 gcc_assert (actual);
1961 maskexpr = actual->expr;
1962 if (maskexpr && maskexpr->rank != 0)
1964 maskss = gfc_walk_expr (maskexpr);
1965 gcc_assert (maskss != gfc_ss_terminator);
1970 /* Initialize the scalarizer. */
1971 gfc_init_loopinfo (&loop);
1972 gfc_add_ss_to_loop (&loop, arrayss);
1974 gfc_add_ss_to_loop (&loop, maskss);
1976 /* Initialize the loop. */
1977 gfc_conv_ss_startstride (&loop);
1978 gfc_conv_loop_setup (&loop, &expr->where);
1980 gfc_mark_ss_chain_used (arrayss, 1);
1982 gfc_mark_ss_chain_used (maskss, 1);
1983 /* Generate the loop body. */
1984 gfc_start_scalarized_body (&loop, &body);
1986 /* If we have a mask, only add this element if the mask is set. */
1989 gfc_init_se (&maskse, NULL);
1990 gfc_copy_loopinfo_to_se (&maskse, &loop);
1992 gfc_conv_expr_val (&maskse, maskexpr);
1993 gfc_add_block_to_block (&body, &maskse.pre);
1995 gfc_start_block (&block);
1998 gfc_init_block (&block);
2000 /* Do the actual summation/product. */
2001 gfc_init_se (&arrayse, NULL);
2002 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2003 arrayse.ss = arrayss;
2004 gfc_conv_expr_val (&arrayse, arrayexpr);
2005 gfc_add_block_to_block (&block, &arrayse.pre);
2007 tmp = fold_build2 (op, type, resvar, arrayse.expr);
2008 gfc_add_modify (&block, resvar, tmp);
2009 gfc_add_block_to_block (&block, &arrayse.post);
2013 /* We enclose the above in if (mask) {...} . */
2014 tmp = gfc_finish_block (&block);
2016 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2017 build_empty_stmt (input_location));
2020 tmp = gfc_finish_block (&block);
2021 gfc_add_expr_to_block (&body, tmp);
2023 gfc_trans_scalarizing_loops (&loop, &body);
2025 /* For a scalar mask, enclose the loop in an if statement. */
2026 if (maskexpr && maskss == NULL)
2028 gfc_init_se (&maskse, NULL);
2029 gfc_conv_expr_val (&maskse, maskexpr);
2030 gfc_init_block (&block);
2031 gfc_add_block_to_block (&block, &loop.pre);
2032 gfc_add_block_to_block (&block, &loop.post);
2033 tmp = gfc_finish_block (&block);
2035 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2036 build_empty_stmt (input_location));
2037 gfc_add_expr_to_block (&block, tmp);
2038 gfc_add_block_to_block (&se->pre, &block);
2042 gfc_add_block_to_block (&se->pre, &loop.pre);
2043 gfc_add_block_to_block (&se->pre, &loop.post);
2046 gfc_cleanup_loop (&loop);
2052 /* Inline implementation of the dot_product intrinsic. This function
2053 is based on gfc_conv_intrinsic_arith (the previous function). */
2055 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2063 gfc_actual_arglist *actual;
2064 gfc_ss *arrayss1, *arrayss2;
2065 gfc_se arrayse1, arrayse2;
2066 gfc_expr *arrayexpr1, *arrayexpr2;
2068 type = gfc_typenode_for_spec (&expr->ts);
2070 /* Initialize the result. */
2071 resvar = gfc_create_var (type, "val");
2072 if (expr->ts.type == BT_LOGICAL)
2073 tmp = build_int_cst (type, 0);
2075 tmp = gfc_build_const (type, integer_zero_node);
2077 gfc_add_modify (&se->pre, resvar, tmp);
2079 /* Walk argument #1. */
2080 actual = expr->value.function.actual;
2081 arrayexpr1 = actual->expr;
2082 arrayss1 = gfc_walk_expr (arrayexpr1);
2083 gcc_assert (arrayss1 != gfc_ss_terminator);
2085 /* Walk argument #2. */
2086 actual = actual->next;
2087 arrayexpr2 = actual->expr;
2088 arrayss2 = gfc_walk_expr (arrayexpr2);
2089 gcc_assert (arrayss2 != gfc_ss_terminator);
2091 /* Initialize the scalarizer. */
2092 gfc_init_loopinfo (&loop);
2093 gfc_add_ss_to_loop (&loop, arrayss1);
2094 gfc_add_ss_to_loop (&loop, arrayss2);
2096 /* Initialize the loop. */
2097 gfc_conv_ss_startstride (&loop);
2098 gfc_conv_loop_setup (&loop, &expr->where);
2100 gfc_mark_ss_chain_used (arrayss1, 1);
2101 gfc_mark_ss_chain_used (arrayss2, 1);
2103 /* Generate the loop body. */
2104 gfc_start_scalarized_body (&loop, &body);
2105 gfc_init_block (&block);
2107 /* Make the tree expression for [conjg(]array1[)]. */
2108 gfc_init_se (&arrayse1, NULL);
2109 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2110 arrayse1.ss = arrayss1;
2111 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2112 if (expr->ts.type == BT_COMPLEX)
2113 arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2114 gfc_add_block_to_block (&block, &arrayse1.pre);
2116 /* Make the tree expression for array2. */
2117 gfc_init_se (&arrayse2, NULL);
2118 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2119 arrayse2.ss = arrayss2;
2120 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2121 gfc_add_block_to_block (&block, &arrayse2.pre);
2123 /* Do the actual product and sum. */
2124 if (expr->ts.type == BT_LOGICAL)
2126 tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2127 tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2131 tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2132 tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2134 gfc_add_modify (&block, resvar, tmp);
2136 /* Finish up the loop block and the loop. */
2137 tmp = gfc_finish_block (&block);
2138 gfc_add_expr_to_block (&body, tmp);
2140 gfc_trans_scalarizing_loops (&loop, &body);
2141 gfc_add_block_to_block (&se->pre, &loop.pre);
2142 gfc_add_block_to_block (&se->pre, &loop.post);
2143 gfc_cleanup_loop (&loop);
2149 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2150 we need to handle. For performance reasons we sometimes create two
2151 loops instead of one, where the second one is much simpler.
2152 Examples for minloc intrinsic:
2153 1) Result is an array, a call is generated
2154 2) Array mask is used and NaNs need to be supported:
2160 if (pos == 0) pos = S + (1 - from);
2161 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2168 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2172 3) NaNs need to be supported, but it is known at compile time or cheaply
2173 at runtime whether array is nonempty or not:
2178 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2181 if (from <= to) pos = 1;
2185 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2189 4) NaNs aren't supported, array mask is used:
2190 limit = infinities_supported ? Infinity : huge (limit);
2194 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2200 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2204 5) Same without array mask:
2205 limit = infinities_supported ? Infinity : huge (limit);
2206 pos = (from <= to) ? 1 : 0;
2209 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2212 For 3) and 5), if mask is scalar, this all goes into a conditional,
2213 setting pos = 0; in the else branch. */
2216 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2220 stmtblock_t ifblock;
2221 stmtblock_t elseblock;
2232 gfc_actual_arglist *actual;
2237 gfc_expr *arrayexpr;
2244 gfc_conv_intrinsic_funcall (se, expr);
2248 /* Initialize the result. */
2249 pos = gfc_create_var (gfc_array_index_type, "pos");
2250 offset = gfc_create_var (gfc_array_index_type, "offset");
2251 type = gfc_typenode_for_spec (&expr->ts);
2253 /* Walk the arguments. */
2254 actual = expr->value.function.actual;
2255 arrayexpr = actual->expr;
2256 arrayss = gfc_walk_expr (arrayexpr);
2257 gcc_assert (arrayss != gfc_ss_terminator);
2259 actual = actual->next->next;
2260 gcc_assert (actual);
2261 maskexpr = actual->expr;
2263 if (maskexpr && maskexpr->rank != 0)
2265 maskss = gfc_walk_expr (maskexpr);
2266 gcc_assert (maskss != gfc_ss_terminator);
2271 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2273 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2275 nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2276 gfc_index_zero_node);
2281 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2282 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2283 switch (arrayexpr->ts.type)
2286 if (HONOR_INFINITIES (DECL_MODE (limit)))
2288 REAL_VALUE_TYPE real;
2290 tmp = build_real (TREE_TYPE (limit), real);
2293 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2294 arrayexpr->ts.kind, 0);
2298 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2299 arrayexpr->ts.kind);
2306 /* We start with the most negative possible value for MAXLOC, and the most
2307 positive possible value for MINLOC. The most negative possible value is
2308 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2309 possible value is HUGE in both cases. */
2311 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2312 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2313 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2314 build_int_cst (type, 1));
2316 gfc_add_modify (&se->pre, limit, tmp);
2318 /* Initialize the scalarizer. */
2319 gfc_init_loopinfo (&loop);
2320 gfc_add_ss_to_loop (&loop, arrayss);
2322 gfc_add_ss_to_loop (&loop, maskss);
2324 /* Initialize the loop. */
2325 gfc_conv_ss_startstride (&loop);
2326 gfc_conv_loop_setup (&loop, &expr->where);
2328 gcc_assert (loop.dimen == 1);
2329 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2330 nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2335 /* Initialize the position to zero, following Fortran 2003. We are free
2336 to do this because Fortran 95 allows the result of an entirely false
2337 mask to be processor dependent. If we know at compile time the array
2338 is non-empty and no MASK is used, we can initialize to 1 to simplify
2340 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2341 gfc_add_modify (&loop.pre, pos,
2342 fold_build3 (COND_EXPR, gfc_array_index_type,
2343 nonempty, gfc_index_one_node,
2344 gfc_index_zero_node));
2347 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2348 lab1 = gfc_build_label_decl (NULL_TREE);
2349 TREE_USED (lab1) = 1;
2350 lab2 = gfc_build_label_decl (NULL_TREE);
2351 TREE_USED (lab2) = 1;
2354 gfc_mark_ss_chain_used (arrayss, 1);
2356 gfc_mark_ss_chain_used (maskss, 1);
2357 /* Generate the loop body. */
2358 gfc_start_scalarized_body (&loop, &body);
2360 /* If we have a mask, only check this element if the mask is set. */
2363 gfc_init_se (&maskse, NULL);
2364 gfc_copy_loopinfo_to_se (&maskse, &loop);
2366 gfc_conv_expr_val (&maskse, maskexpr);
2367 gfc_add_block_to_block (&body, &maskse.pre);
2369 gfc_start_block (&block);
2372 gfc_init_block (&block);
2374 /* Compare with the current limit. */
2375 gfc_init_se (&arrayse, NULL);
2376 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2377 arrayse.ss = arrayss;
2378 gfc_conv_expr_val (&arrayse, arrayexpr);
2379 gfc_add_block_to_block (&block, &arrayse.pre);
2381 /* We do the following if this is a more extreme value. */
2382 gfc_start_block (&ifblock);
2384 /* Assign the value to the limit... */
2385 gfc_add_modify (&ifblock, limit, arrayse.expr);
2387 /* Remember where we are. An offset must be added to the loop
2388 counter to obtain the required position. */
2390 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2391 gfc_index_one_node, loop.from[0]);
2393 tmp = gfc_index_one_node;
2395 gfc_add_modify (&block, offset, tmp);
2397 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2399 stmtblock_t ifblock2;
2402 gfc_start_block (&ifblock2);
2403 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2404 loop.loopvar[0], offset);
2405 gfc_add_modify (&ifblock2, pos, tmp);
2406 ifbody2 = gfc_finish_block (&ifblock2);
2407 cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
2408 gfc_index_zero_node);
2409 tmp = build3_v (COND_EXPR, cond, ifbody2,
2410 build_empty_stmt (input_location));
2411 gfc_add_expr_to_block (&block, tmp);
2414 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2415 loop.loopvar[0], offset);
2416 gfc_add_modify (&ifblock, pos, tmp);
2419 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2421 ifbody = gfc_finish_block (&ifblock);
2423 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2426 cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2427 boolean_type_node, arrayse.expr, limit);
2429 cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2431 ifbody = build3_v (COND_EXPR, cond, ifbody,
2432 build_empty_stmt (input_location));
2434 gfc_add_expr_to_block (&block, ifbody);
2438 /* We enclose the above in if (mask) {...}. */
2439 tmp = gfc_finish_block (&block);
2441 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2442 build_empty_stmt (input_location));
2445 tmp = gfc_finish_block (&block);
2446 gfc_add_expr_to_block (&body, tmp);
2450 gfc_trans_scalarized_loop_end (&loop, 0, &body);
2452 if (HONOR_NANS (DECL_MODE (limit)))
2454 if (nonempty != NULL)
2456 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2457 tmp = build3_v (COND_EXPR, nonempty, ifbody,
2458 build_empty_stmt (input_location));
2459 gfc_add_expr_to_block (&loop.code[0], tmp);
2463 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2464 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2465 gfc_start_block (&body);
2467 /* If we have a mask, only check this element if the mask is set. */
2470 gfc_init_se (&maskse, NULL);
2471 gfc_copy_loopinfo_to_se (&maskse, &loop);
2473 gfc_conv_expr_val (&maskse, maskexpr);
2474 gfc_add_block_to_block (&body, &maskse.pre);
2476 gfc_start_block (&block);
2479 gfc_init_block (&block);
2481 /* Compare with the current limit. */
2482 gfc_init_se (&arrayse, NULL);
2483 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2484 arrayse.ss = arrayss;
2485 gfc_conv_expr_val (&arrayse, arrayexpr);
2486 gfc_add_block_to_block (&block, &arrayse.pre);
2488 /* We do the following if this is a more extreme value. */
2489 gfc_start_block (&ifblock);
2491 /* Assign the value to the limit... */
2492 gfc_add_modify (&ifblock, limit, arrayse.expr);
2494 /* Remember where we are. An offset must be added to the loop
2495 counter to obtain the required position. */
2497 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2498 gfc_index_one_node, loop.from[0]);
2500 tmp = gfc_index_one_node;
2502 gfc_add_modify (&block, offset, tmp);
2504 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2505 loop.loopvar[0], offset);
2506 gfc_add_modify (&ifblock, pos, tmp);
2508 ifbody = gfc_finish_block (&ifblock);
2510 cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2512 tmp = build3_v (COND_EXPR, cond, ifbody,
2513 build_empty_stmt (input_location));
2514 gfc_add_expr_to_block (&block, tmp);
2518 /* We enclose the above in if (mask) {...}. */
2519 tmp = gfc_finish_block (&block);
2521 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2522 build_empty_stmt (input_location));
2525 tmp = gfc_finish_block (&block);
2526 gfc_add_expr_to_block (&body, tmp);
2527 /* Avoid initializing loopvar[0] again, it should be left where
2528 it finished by the first loop. */
2529 loop.from[0] = loop.loopvar[0];
2532 gfc_trans_scalarizing_loops (&loop, &body);
2535 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2537 /* For a scalar mask, enclose the loop in an if statement. */
2538 if (maskexpr && maskss == NULL)
2540 gfc_init_se (&maskse, NULL);
2541 gfc_conv_expr_val (&maskse, maskexpr);
2542 gfc_init_block (&block);
2543 gfc_add_block_to_block (&block, &loop.pre);
2544 gfc_add_block_to_block (&block, &loop.post);
2545 tmp = gfc_finish_block (&block);
2547 /* For the else part of the scalar mask, just initialize
2548 the pos variable the same way as above. */
2550 gfc_init_block (&elseblock);
2551 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2552 elsetmp = gfc_finish_block (&elseblock);
2554 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2555 gfc_add_expr_to_block (&block, tmp);
2556 gfc_add_block_to_block (&se->pre, &block);
2560 gfc_add_block_to_block (&se->pre, &loop.pre);
2561 gfc_add_block_to_block (&se->pre, &loop.post);
2563 gfc_cleanup_loop (&loop);
2565 se->expr = convert (type, pos);
2568 /* Emit code for minval or maxval intrinsic. There are many different cases
2569 we need to handle. For performance reasons we sometimes create two
2570 loops instead of one, where the second one is much simpler.
2571 Examples for minval intrinsic:
2572 1) Result is an array, a call is generated
2573 2) Array mask is used and NaNs need to be supported, rank 1:
2578 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2581 limit = nonempty ? NaN : huge (limit);
2583 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2584 3) NaNs need to be supported, but it is known at compile time or cheaply
2585 at runtime whether array is nonempty or not, rank 1:
2588 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2589 limit = (from <= to) ? NaN : huge (limit);
2591 while (S <= to) { limit = min (a[S], limit); S++; }
2592 4) Array mask is used and NaNs need to be supported, rank > 1:
2601 if (fast) limit = min (a[S1][S2], limit);
2604 if (a[S1][S2] <= limit) {
2615 limit = nonempty ? NaN : huge (limit);
2616 5) NaNs need to be supported, but it is known at compile time or cheaply
2617 at runtime whether array is nonempty or not, rank > 1:
2624 if (fast) limit = min (a[S1][S2], limit);
2626 if (a[S1][S2] <= limit) {
2636 limit = (nonempty_array) ? NaN : huge (limit);
2637 6) NaNs aren't supported, but infinities are. Array mask is used:
2642 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2645 limit = nonempty ? limit : huge (limit);
2646 7) Same without array mask:
2649 while (S <= to) { limit = min (a[S], limit); S++; }
2650 limit = (from <= to) ? limit : huge (limit);
2651 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2652 limit = huge (limit);
2654 while (S <= to) { limit = min (a[S], limit); S++); }
2656 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2657 with array mask instead).
2658 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2659 setting limit = huge (limit); in the else branch. */
2662 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2672 tree huge_cst = NULL, nan_cst = NULL;
2674 stmtblock_t block, block2;
2676 gfc_actual_arglist *actual;
2681 gfc_expr *arrayexpr;
2687 gfc_conv_intrinsic_funcall (se, expr);
2691 type = gfc_typenode_for_spec (&expr->ts);
2692 /* Initialize the result. */
2693 limit = gfc_create_var (type, "limit");
2694 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2695 switch (expr->ts.type)
2698 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2700 if (HONOR_INFINITIES (DECL_MODE (limit)))
2702 REAL_VALUE_TYPE real;
2704 tmp = build_real (type, real);
2708 if (HONOR_NANS (DECL_MODE (limit)))
2710 REAL_VALUE_TYPE real;
2711 real_nan (&real, "", 1, DECL_MODE (limit));
2712 nan_cst = build_real (type, real);
2717 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2724 /* We start with the most negative possible value for MAXVAL, and the most
2725 positive possible value for MINVAL. The most negative possible value is
2726 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2727 possible value is HUGE in both cases. */
2730 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2732 huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
2735 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2736 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2737 tmp, build_int_cst (type, 1));
2739 gfc_add_modify (&se->pre, limit, tmp);
2741 /* Walk the arguments. */
2742 actual = expr->value.function.actual;
2743 arrayexpr = actual->expr;
2744 arrayss = gfc_walk_expr (arrayexpr);
2745 gcc_assert (arrayss != gfc_ss_terminator);
2747 actual = actual->next->next;
2748 gcc_assert (actual);
2749 maskexpr = actual->expr;
2751 if (maskexpr && maskexpr->rank != 0)
2753 maskss = gfc_walk_expr (maskexpr);
2754 gcc_assert (maskss != gfc_ss_terminator);
2759 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2761 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2763 nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2764 gfc_index_zero_node);
2769 /* Initialize the scalarizer. */
2770 gfc_init_loopinfo (&loop);
2771 gfc_add_ss_to_loop (&loop, arrayss);
2773 gfc_add_ss_to_loop (&loop, maskss);
2775 /* Initialize the loop. */
2776 gfc_conv_ss_startstride (&loop);
2777 gfc_conv_loop_setup (&loop, &expr->where);
2779 if (nonempty == NULL && maskss == NULL
2780 && loop.dimen == 1 && loop.from[0] && loop.to[0])
2781 nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2783 nonempty_var = NULL;
2784 if (nonempty == NULL
2785 && (HONOR_INFINITIES (DECL_MODE (limit))
2786 || HONOR_NANS (DECL_MODE (limit))))
2788 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2789 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2790 nonempty = nonempty_var;
2794 if (HONOR_NANS (DECL_MODE (limit)))
2796 if (loop.dimen == 1)
2798 lab = gfc_build_label_decl (NULL_TREE);
2799 TREE_USED (lab) = 1;
2803 fast = gfc_create_var (boolean_type_node, "fast");
2804 gfc_add_modify (&se->pre, fast, boolean_false_node);
2808 gfc_mark_ss_chain_used (arrayss, 1);
2810 gfc_mark_ss_chain_used (maskss, 1);
2811 /* Generate the loop body. */
2812 gfc_start_scalarized_body (&loop, &body);
2814 /* If we have a mask, only add this element if the mask is set. */
2817 gfc_init_se (&maskse, NULL);
2818 gfc_copy_loopinfo_to_se (&maskse, &loop);
2820 gfc_conv_expr_val (&maskse, maskexpr);
2821 gfc_add_block_to_block (&body, &maskse.pre);
2823 gfc_start_block (&block);
2826 gfc_init_block (&block);
2828 /* Compare with the current limit. */
2829 gfc_init_se (&arrayse, NULL);
2830 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2831 arrayse.ss = arrayss;
2832 gfc_conv_expr_val (&arrayse, arrayexpr);
2833 gfc_add_block_to_block (&block, &arrayse.pre);
2835 gfc_init_block (&block2);
2838 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2840 if (HONOR_NANS (DECL_MODE (limit)))
2842 tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2843 boolean_type_node, arrayse.expr, limit);
2845 ifbody = build1_v (GOTO_EXPR, lab);
2848 stmtblock_t ifblock;
2850 gfc_init_block (&ifblock);
2851 gfc_add_modify (&ifblock, limit, arrayse.expr);
2852 gfc_add_modify (&ifblock, fast, boolean_true_node);
2853 ifbody = gfc_finish_block (&ifblock);
2855 tmp = build3_v (COND_EXPR, tmp, ifbody,
2856 build_empty_stmt (input_location));
2857 gfc_add_expr_to_block (&block2, tmp);
2861 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2863 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2865 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2866 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2867 tmp = build3_v (COND_EXPR, tmp, ifbody,
2868 build_empty_stmt (input_location));
2869 gfc_add_expr_to_block (&block2, tmp);
2873 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2874 type, arrayse.expr, limit);
2875 gfc_add_modify (&block2, limit, tmp);
2881 tree elsebody = gfc_finish_block (&block2);
2883 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2885 if (HONOR_NANS (DECL_MODE (limit))
2886 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2888 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2889 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2890 ifbody = build3_v (COND_EXPR, tmp, ifbody,
2891 build_empty_stmt (input_location));
2895 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2896 type, arrayse.expr, limit);
2897 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2899 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
2900 gfc_add_expr_to_block (&block, tmp);
2903 gfc_add_block_to_block (&block, &block2);
2905 gfc_add_block_to_block (&block, &arrayse.post);
2907 tmp = gfc_finish_block (&block);
2909 /* We enclose the above in if (mask) {...}. */
2910 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2911 build_empty_stmt (input_location));
2912 gfc_add_expr_to_block (&body, tmp);
2916 gfc_trans_scalarized_loop_end (&loop, 0, &body);
2918 tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2919 gfc_add_modify (&loop.code[0], limit, tmp);
2920 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
2922 gfc_start_block (&body);
2924 /* If we have a mask, only add this element if the mask is set. */
2927 gfc_init_se (&maskse, NULL);
2928 gfc_copy_loopinfo_to_se (&maskse, &loop);
2930 gfc_conv_expr_val (&maskse, maskexpr);
2931 gfc_add_block_to_block (&body, &maskse.pre);
2933 gfc_start_block (&block);
2936 gfc_init_block (&block);
2938 /* Compare with the current limit. */
2939 gfc_init_se (&arrayse, NULL);
2940 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2941 arrayse.ss = arrayss;
2942 gfc_conv_expr_val (&arrayse, arrayexpr);
2943 gfc_add_block_to_block (&block, &arrayse.pre);
2945 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2947 if (HONOR_NANS (DECL_MODE (limit))
2948 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2950 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2951 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2952 tmp = build3_v (COND_EXPR, tmp, ifbody,
2953 build_empty_stmt (input_location));
2954 gfc_add_expr_to_block (&block, tmp);
2958 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2959 type, arrayse.expr, limit);
2960 gfc_add_modify (&block, limit, tmp);
2963 gfc_add_block_to_block (&block, &arrayse.post);
2965 tmp = gfc_finish_block (&block);
2967 /* We enclose the above in if (mask) {...}. */
2968 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2969 build_empty_stmt (input_location));
2970 gfc_add_expr_to_block (&body, tmp);
2971 /* Avoid initializing loopvar[0] again, it should be left where
2972 it finished by the first loop. */
2973 loop.from[0] = loop.loopvar[0];
2975 gfc_trans_scalarizing_loops (&loop, &body);
2979 tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2980 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2981 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
2983 gfc_add_expr_to_block (&loop.pre, tmp);
2985 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
2987 tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
2988 gfc_add_modify (&loop.pre, limit, tmp);
2991 /* For a scalar mask, enclose the loop in an if statement. */
2992 if (maskexpr && maskss == NULL)
2996 gfc_init_se (&maskse, NULL);
2997 gfc_conv_expr_val (&maskse, maskexpr);
2998 gfc_init_block (&block);
2999 gfc_add_block_to_block (&block, &loop.pre);
3000 gfc_add_block_to_block (&block, &loop.post);
3001 tmp = gfc_finish_block (&block);
3003 if (HONOR_INFINITIES (DECL_MODE (limit)))
3004 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3006 else_stmt = build_empty_stmt (input_location);
3007 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3008 gfc_add_expr_to_block (&block, tmp);
3009 gfc_add_block_to_block (&se->pre, &block);
3013 gfc_add_block_to_block (&se->pre, &loop.pre);
3014 gfc_add_block_to_block (&se->pre, &loop.post);
3017 gfc_cleanup_loop (&loop);
3022 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3024 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3030 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3031 type = TREE_TYPE (args[0]);
3033 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3034 tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
3035 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
3036 build_int_cst (type, 0));
3037 type = gfc_typenode_for_spec (&expr->ts);
3038 se->expr = convert (type, tmp);
3041 /* Generate code to perform the specified operation. */
3043 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3047 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3048 se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
3053 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3057 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3058 se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
3061 /* Set or clear a single bit. */
3063 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3070 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3071 type = TREE_TYPE (args[0]);
3073 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3079 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
3081 se->expr = fold_build2 (op, type, args[0], tmp);
3084 /* Extract a sequence of bits.
3085 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3087 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3094 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3095 type = TREE_TYPE (args[0]);
3097 mask = build_int_cst (type, -1);
3098 mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
3099 mask = fold_build1 (BIT_NOT_EXPR, type, mask);
3101 tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
3103 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
3106 /* RSHIFT (I, SHIFT) = I >> SHIFT
3107 LSHIFT (I, SHIFT) = I << SHIFT */
3109 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3113 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3115 se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3116 TREE_TYPE (args[0]), args[0], args[1]);
3119 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3121 : ((shift >= 0) ? i << shift : i >> -shift)
3122 where all shifts are logical shifts. */
3124 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3136 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3137 type = TREE_TYPE (args[0]);
3138 utype = unsigned_type_for (type);
3140 width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
3142 /* Left shift if positive. */
3143 lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
3145 /* Right shift if negative.
3146 We convert to an unsigned type because we want a logical shift.
3147 The standard doesn't define the case of shifting negative
3148 numbers, and we try to be compatible with other compilers, most
3149 notably g77, here. */
3150 rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
3151 convert (utype, args[0]), width));
3153 tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
3154 build_int_cst (TREE_TYPE (args[1]), 0));
3155 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
3157 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3158 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3160 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3161 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
3163 se->expr = fold_build3 (COND_EXPR, type, cond,
3164 build_int_cst (type, 0), tmp);
3168 /* Circular shift. AKA rotate or barrel shift. */
3171 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3179 unsigned int num_args;
3181 num_args = gfc_intrinsic_argument_list_length (expr);
3182 args = (tree *) alloca (sizeof (tree) * num_args);
3184 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3188 /* Use a library function for the 3 parameter version. */
3189 tree int4type = gfc_get_int_type (4);
3191 type = TREE_TYPE (args[0]);
3192 /* We convert the first argument to at least 4 bytes, and
3193 convert back afterwards. This removes the need for library
3194 functions for all argument sizes, and function will be
3195 aligned to at least 32 bits, so there's no loss. */
3196 if (expr->ts.kind < 4)
3197 args[0] = convert (int4type, args[0]);
3199 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3200 need loads of library functions. They cannot have values >
3201 BIT_SIZE (I) so the conversion is safe. */
3202 args[1] = convert (int4type, args[1]);
3203 args[2] = convert (int4type, args[2]);
3205 switch (expr->ts.kind)
3210 tmp = gfor_fndecl_math_ishftc4;
3213 tmp = gfor_fndecl_math_ishftc8;
3216 tmp = gfor_fndecl_math_ishftc16;
3221 se->expr = build_call_expr_loc (input_location,
3222 tmp, 3, args[0], args[1], args[2]);
3223 /* Convert the result back to the original type, if we extended
3224 the first argument's width above. */
3225 if (expr->ts.kind < 4)
3226 se->expr = convert (type, se->expr);
3230 type = TREE_TYPE (args[0]);
3232 /* Rotate left if positive. */
3233 lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
3235 /* Rotate right if negative. */
3236 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
3237 rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
3239 zero = build_int_cst (TREE_TYPE (args[1]), 0);
3240 tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
3241 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
3243 /* Do nothing if shift == 0. */
3244 tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
3245 se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
3248 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3249 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3251 The conditional expression is necessary because the result of LEADZ(0)
3252 is defined, but the result of __builtin_clz(0) is undefined for most
3255 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3256 difference in bit size between the argument of LEADZ and the C int. */
3259 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3271 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3272 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3274 /* Which variant of __builtin_clz* should we call? */
3275 if (argsize <= INT_TYPE_SIZE)
3277 arg_type = unsigned_type_node;
3278 func = built_in_decls[BUILT_IN_CLZ];
3280 else if (argsize <= LONG_TYPE_SIZE)
3282 arg_type = long_unsigned_type_node;
3283 func = built_in_decls[BUILT_IN_CLZL];
3285 else if (argsize <= LONG_LONG_TYPE_SIZE)
3287 arg_type = long_long_unsigned_type_node;
3288 func = built_in_decls[BUILT_IN_CLZLL];
3292 gcc_assert (argsize == 128);
3293 arg_type = gfc_build_uint_type (argsize);
3294 func = gfor_fndecl_clz128;
3297 /* Convert the actual argument twice: first, to the unsigned type of the
3298 same size; then, to the proper argument type for the built-in
3299 function. But the return type is of the default INTEGER kind. */
3300 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3301 arg = fold_convert (arg_type, arg);
3302 result_type = gfc_get_int_type (gfc_default_integer_kind);
3304 /* Compute LEADZ for the case i .ne. 0. */
3305 s = TYPE_PRECISION (arg_type) - argsize;
3306 tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
3307 leadz = fold_build2 (MINUS_EXPR, result_type,
3308 tmp, build_int_cst (result_type, s));
3310 /* Build BIT_SIZE. */
3311 bit_size = build_int_cst (result_type, argsize);
3313 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3314 arg, build_int_cst (arg_type, 0));
3315 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
3318 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3320 The conditional expression is necessary because the result of TRAILZ(0)
3321 is defined, but the result of __builtin_ctz(0) is undefined for most
3325 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3336 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3337 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3339 /* Which variant of __builtin_ctz* should we call? */
3340 if (argsize <= INT_TYPE_SIZE)
3342 arg_type = unsigned_type_node;
3343 func = built_in_decls[BUILT_IN_CTZ];
3345 else if (argsize <= LONG_TYPE_SIZE)
3347 arg_type = long_unsigned_type_node;
3348 func = built_in_decls[BUILT_IN_CTZL];
3350 else if (argsize <= LONG_LONG_TYPE_SIZE)
3352 arg_type = long_long_unsigned_type_node;
3353 func = built_in_decls[BUILT_IN_CTZLL];
3357 gcc_assert (argsize == 128);
3358 arg_type = gfc_build_uint_type (argsize);
3359 func = gfor_fndecl_ctz128;
3362 /* Convert the actual argument twice: first, to the unsigned type of the
3363 same size; then, to the proper argument type for the built-in
3364 function. But the return type is of the default INTEGER kind. */
3365 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3366 arg = fold_convert (arg_type, arg);
3367 result_type = gfc_get_int_type (gfc_default_integer_kind);
3369 /* Compute TRAILZ for the case i .ne. 0. */
3370 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3373 /* Build BIT_SIZE. */
3374 bit_size = build_int_cst (result_type, argsize);
3376 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3377 arg, build_int_cst (arg_type, 0));
3378 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
3381 /* Process an intrinsic with unspecified argument-types that has an optional
3382 argument (which could be of type character), e.g. EOSHIFT. For those, we
3383 need to append the string length of the optional argument if it is not
3384 present and the type is really character.
3385 primary specifies the position (starting at 1) of the non-optional argument
3386 specifying the type and optional gives the position of the optional
3387 argument in the arglist. */
3390 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3391 unsigned primary, unsigned optional)
3393 gfc_actual_arglist* prim_arg;
3394 gfc_actual_arglist* opt_arg;
3396 gfc_actual_arglist* arg;
3400 /* Find the two arguments given as position. */
3404 for (arg = expr->value.function.actual; arg; arg = arg->next)
3408 if (cur_pos == primary)
3410 if (cur_pos == optional)
3413 if (cur_pos >= primary && cur_pos >= optional)
3416 gcc_assert (prim_arg);
3417 gcc_assert (prim_arg->expr);
3418 gcc_assert (opt_arg);
3420 /* If we do have type CHARACTER and the optional argument is really absent,
3421 append a dummy 0 as string length. */
3422 append_args = NULL_TREE;
3423 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3427 dummy = build_int_cst (gfc_charlen_type_node, 0);
3428 append_args = gfc_chainon_list (append_args, dummy);
3431 /* Build the call itself. */
3432 sym = gfc_get_symbol_for_expr (expr);
3433 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3439 /* The length of a character string. */
3441 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3451 gcc_assert (!se->ss);
3453 arg = expr->value.function.actual->expr;
3455 type = gfc_typenode_for_spec (&expr->ts);
3456 switch (arg->expr_type)
3459 len = build_int_cst (NULL_TREE, arg->value.character.length);
3463 /* Obtain the string length from the function used by
3464 trans-array.c(gfc_trans_array_constructor). */
3466 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3470 if (arg->ref == NULL
3471 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3473 /* This doesn't catch all cases.
3474 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3475 and the surrounding thread. */
3476 sym = arg->symtree->n.sym;
3477 decl = gfc_get_symbol_decl (sym);
3478 if (decl == current_function_decl && sym->attr.function
3479 && (sym->result == sym))
3480 decl = gfc_get_fake_result_decl (sym, 0);
3482 len = sym->ts.cl->backend_decl;
3487 /* Otherwise fall through. */
3490 /* Anybody stupid enough to do this deserves inefficient code. */
3491 ss = gfc_walk_expr (arg);
3492 gfc_init_se (&argse, se);
3493 if (ss == gfc_ss_terminator)
3494 gfc_conv_expr (&argse, arg);
3496 gfc_conv_expr_descriptor (&argse, arg, ss);
3497 gfc_add_block_to_block (&se->pre, &argse.pre);
3498 gfc_add_block_to_block (&se->post, &argse.post);
3499 len = argse.string_length;
3502 se->expr = convert (type, len);
3505 /* The length of a character string not including trailing blanks. */
3507 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3509 int kind = expr->value.function.actual->expr->ts.kind;
3510 tree args[2], type, fndecl;
3512 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3513 type = gfc_typenode_for_spec (&expr->ts);
3516 fndecl = gfor_fndecl_string_len_trim;
3518 fndecl = gfor_fndecl_string_len_trim_char4;
3522 se->expr = build_call_expr_loc (input_location,
3523 fndecl, 2, args[0], args[1]);
3524 se->expr = convert (type, se->expr);
3528 /* Returns the starting position of a substring within a string. */
3531 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3534 tree logical4_type_node = gfc_get_logical_type (4);
3538 unsigned int num_args;
3540 args = (tree *) alloca (sizeof (tree) * 5);
3542 /* Get number of arguments; characters count double due to the
3543 string length argument. Kind= is not passed to the library
3544 and thus ignored. */
3545 if (expr->value.function.actual->next->next->expr == NULL)
3550 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3551 type = gfc_typenode_for_spec (&expr->ts);
3554 args[4] = build_int_cst (logical4_type_node, 0);
3556 args[4] = convert (logical4_type_node, args[4]);
3558 fndecl = build_addr (function, current_function_decl);
3559 se->expr = build_call_array_loc (input_location,
3560 TREE_TYPE (TREE_TYPE (function)), fndecl,
3562 se->expr = convert (type, se->expr);
3566 /* The ascii value for a single character. */
3568 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3570 tree args[2], type, pchartype;
3572 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3573 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3574 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3575 args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3576 type = gfc_typenode_for_spec (&expr->ts);
3578 se->expr = build_fold_indirect_ref_loc (input_location,
3580 se->expr = convert (type, se->expr);
3584 /* Intrinsic ISNAN calls __builtin_isnan. */
3587 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3591 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3592 se->expr = build_call_expr_loc (input_location,
3593 built_in_decls[BUILT_IN_ISNAN], 1, arg);
3594 STRIP_TYPE_NOPS (se->expr);
3595 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3599 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3600 their argument against a constant integer value. */
3603 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3607 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3608 se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3609 arg, build_int_cst (TREE_TYPE (arg), value));
3614 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3617 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3625 unsigned int num_args;
3627 num_args = gfc_intrinsic_argument_list_length (expr);
3628 args = (tree *) alloca (sizeof (tree) * num_args);
3630 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3631 if (expr->ts.type != BT_CHARACTER)
3639 /* We do the same as in the non-character case, but the argument
3640 list is different because of the string length arguments. We
3641 also have to set the string length for the result. */
3648 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3650 se->string_length = len;
3652 type = TREE_TYPE (tsource);
3653 se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3654 fold_convert (type, fsource));
3658 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3660 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3662 tree arg, type, tmp;
3665 switch (expr->ts.kind)
3668 frexp = BUILT_IN_FREXPF;
3671 frexp = BUILT_IN_FREXP;
3675 frexp = BUILT_IN_FREXPL;
3681 type = gfc_typenode_for_spec (&expr->ts);
3682 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3683 tmp = gfc_create_var (integer_type_node, NULL);
3684 se->expr = build_call_expr_loc (input_location,
3685 built_in_decls[frexp], 2,
3686 fold_convert (type, arg),
3687 gfc_build_addr_expr (NULL_TREE, tmp));
3688 se->expr = fold_convert (type, se->expr);
3692 /* NEAREST (s, dir) is translated into
3693 tmp = copysign (HUGE_VAL, dir);
3694 return nextafter (s, tmp);
3697 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3699 tree args[2], type, tmp;
3700 int nextafter, copysign, huge_val;
3702 switch (expr->ts.kind)
3705 nextafter = BUILT_IN_NEXTAFTERF;
3706 copysign = BUILT_IN_COPYSIGNF;
3707 huge_val = BUILT_IN_HUGE_VALF;
3710 nextafter = BUILT_IN_NEXTAFTER;
3711 copysign = BUILT_IN_COPYSIGN;
3712 huge_val = BUILT_IN_HUGE_VAL;
3716 nextafter = BUILT_IN_NEXTAFTERL;
3717 copysign = BUILT_IN_COPYSIGNL;
3718 huge_val = BUILT_IN_HUGE_VALL;
3724 type = gfc_typenode_for_spec (&expr->ts);
3725 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3726 tmp = build_call_expr_loc (input_location,
3727 built_in_decls[copysign], 2,
3728 build_call_expr_loc (input_location,
3729 built_in_decls[huge_val], 0),
3730 fold_convert (type, args[1]));
3731 se->expr = build_call_expr_loc (input_location,
3732 built_in_decls[nextafter], 2,
3733 fold_convert (type, args[0]), tmp);
3734 se->expr = fold_convert (type, se->expr);
3738 /* SPACING (s) is translated into
3746 e = MAX_EXPR (e, emin);
3747 res = scalbn (1., e);
3751 where prec is the precision of s, gfc_real_kinds[k].digits,
3752 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3753 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3756 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3758 tree arg, type, prec, emin, tiny, res, e;
3760 int frexp, scalbn, k;
3763 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3764 prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3765 emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3766 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3768 switch (expr->ts.kind)
3771 frexp = BUILT_IN_FREXPF;
3772 scalbn = BUILT_IN_SCALBNF;
3775 frexp = BUILT_IN_FREXP;
3776 scalbn = BUILT_IN_SCALBN;
3780 frexp = BUILT_IN_FREXPL;
3781 scalbn = BUILT_IN_SCALBNL;
3787 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3788 arg = gfc_evaluate_now (arg, &se->pre);
3790 type = gfc_typenode_for_spec (&expr->ts);
3791 e = gfc_create_var (integer_type_node, NULL);
3792 res = gfc_create_var (type, NULL);
3795 /* Build the block for s /= 0. */
3796 gfc_start_block (&block);
3797 tmp = build_call_expr_loc (input_location,
3798 built_in_decls[frexp], 2, arg,
3799 gfc_build_addr_expr (NULL_TREE, e));
3800 gfc_add_expr_to_block (&block, tmp);
3802 tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3803 gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3806 tmp = build_call_expr_loc (input_location,
3807 built_in_decls[scalbn], 2,
3808 build_real_from_int_cst (type, integer_one_node), e);
3809 gfc_add_modify (&block, res, tmp);
3811 /* Finish by building the IF statement. */
3812 cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3813 build_real_from_int_cst (type, integer_zero_node));
3814 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3815 gfc_finish_block (&block));
3817 gfc_add_expr_to_block (&se->pre, tmp);
3822 /* RRSPACING (s) is translated into
3829 x = scalbn (x, precision - e);
3833 where precision is gfc_real_kinds[k].digits. */
3836 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3838 tree arg, type, e, x, cond, stmt, tmp;
3839 int frexp, scalbn, fabs, prec, k;
3842 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3843 prec = gfc_real_kinds[k].digits;
3844 switch (expr->ts.kind)
3847 frexp = BUILT_IN_FREXPF;
3848 scalbn = BUILT_IN_SCALBNF;
3849 fabs = BUILT_IN_FABSF;
3852 frexp = BUILT_IN_FREXP;
3853 scalbn = BUILT_IN_SCALBN;
3854 fabs = BUILT_IN_FABS;
3858 frexp = BUILT_IN_FREXPL;
3859 scalbn = BUILT_IN_SCALBNL;
3860 fabs = BUILT_IN_FABSL;
3866 type = gfc_typenode_for_spec (&expr->ts);
3867 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3868 arg = gfc_evaluate_now (arg, &se->pre);
3870 e = gfc_create_var (integer_type_node, NULL);
3871 x = gfc_create_var (type, NULL);
3872 gfc_add_modify (&se->pre, x,
3873 build_call_expr_loc (input_location,
3874 built_in_decls[fabs], 1, arg));
3877 gfc_start_block (&block);
3878 tmp = build_call_expr_loc (input_location,
3879 built_in_decls[frexp], 2, arg,
3880 gfc_build_addr_expr (NULL_TREE, e));
3881 gfc_add_expr_to_block (&block, tmp);
3883 tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3884 build_int_cst (NULL_TREE, prec), e);
3885 tmp = build_call_expr_loc (input_location,
3886 built_in_decls[scalbn], 2, x, tmp);
3887 gfc_add_modify (&block, x, tmp);
3888 stmt = gfc_finish_block (&block);
3890 cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3891 build_real_from_int_cst (type, integer_zero_node));
3892 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
3893 gfc_add_expr_to_block (&se->pre, tmp);
3895 se->expr = fold_convert (type, x);
3899 /* SCALE (s, i) is translated into scalbn (s, i). */
3901 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3906 switch (expr->ts.kind)
3909 scalbn = BUILT_IN_SCALBNF;
3912 scalbn = BUILT_IN_SCALBN;
3916 scalbn = BUILT_IN_SCALBNL;
3922 type = gfc_typenode_for_spec (&expr->ts);
3923 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3924 se->expr = build_call_expr_loc (input_location,
3925 built_in_decls[scalbn], 2,
3926 fold_convert (type, args[0]),
3927 fold_convert (integer_type_node, args[1]));
3928 se->expr = fold_convert (type, se->expr);
3932 /* SET_EXPONENT (s, i) is translated into
3933 scalbn (frexp (s, &dummy_int), i). */
3935 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3937 tree args[2], type, tmp;
3940 switch (expr->ts.kind)
3943 frexp = BUILT_IN_FREXPF;
3944 scalbn = BUILT_IN_SCALBNF;
3947 frexp = BUILT_IN_FREXP;
3948 scalbn = BUILT_IN_SCALBN;
3952 frexp = BUILT_IN_FREXPL;
3953 scalbn = BUILT_IN_SCALBNL;
3959 type = gfc_typenode_for_spec (&expr->ts);
3960 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3962 tmp = gfc_create_var (integer_type_node, NULL);
3963 tmp = build_call_expr_loc (input_location,
3964 built_in_decls[frexp], 2,
3965 fold_convert (type, args[0]),
3966 gfc_build_addr_expr (NULL_TREE, tmp));
3967 se->expr = build_call_expr_loc (input_location,
3968 built_in_decls[scalbn], 2, tmp,
3969 fold_convert (integer_type_node, args[1]));
3970 se->expr = fold_convert (type, se->expr);
3975 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3977 gfc_actual_arglist *actual;
3985 gfc_init_se (&argse, NULL);
3986 actual = expr->value.function.actual;
3988 ss = gfc_walk_expr (actual->expr);
3989 gcc_assert (ss != gfc_ss_terminator);
3990 argse.want_pointer = 1;
3991 argse.data_not_needed = 1;
3992 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3993 gfc_add_block_to_block (&se->pre, &argse.pre);
3994 gfc_add_block_to_block (&se->post, &argse.post);
3995 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3997 /* Build the call to size0. */
3998 fncall0 = build_call_expr_loc (input_location,
3999 gfor_fndecl_size0, 1, arg1);
4001 actual = actual->next;
4005 gfc_init_se (&argse, NULL);
4006 gfc_conv_expr_type (&argse, actual->expr,
4007 gfc_array_index_type);
4008 gfc_add_block_to_block (&se->pre, &argse.pre);
4010 /* Unusually, for an intrinsic, size does not exclude
4011 an optional arg2, so we must test for it. */
4012 if (actual->expr->expr_type == EXPR_VARIABLE
4013 && actual->expr->symtree->n.sym->attr.dummy
4014 && actual->expr->symtree->n.sym->attr.optional)
4017 /* Build the call to size1. */
4018 fncall1 = build_call_expr_loc (input_location,
4019 gfor_fndecl_size1, 2,
4022 gfc_init_se (&argse, NULL);
4023 argse.want_pointer = 1;
4024 argse.data_not_needed = 1;
4025 gfc_conv_expr (&argse, actual->expr);
4026 gfc_add_block_to_block (&se->pre, &argse.pre);
4027 tmp = fold_build2 (NE_EXPR, boolean_type_node,
4028 argse.expr, null_pointer_node);
4029 tmp = gfc_evaluate_now (tmp, &se->pre);
4030 se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
4031 tmp, fncall1, fncall0);
4035 se->expr = NULL_TREE;
4036 argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4037 argse.expr, gfc_index_one_node);
4040 else if (expr->value.function.actual->expr->rank == 1)
4042 argse.expr = gfc_index_zero_node;
4043 se->expr = NULL_TREE;
4048 if (se->expr == NULL_TREE)
4050 tree ubound, lbound;
4052 arg1 = build_fold_indirect_ref_loc (input_location,
4054 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
4055 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
4056 se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4058 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
4059 gfc_index_one_node);
4060 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
4061 gfc_index_zero_node);
4064 type = gfc_typenode_for_spec (&expr->ts);
4065 se->expr = convert (type, se->expr);
4069 /* Helper function to compute the size of a character variable,
4070 excluding the terminating null characters. The result has
4071 gfc_array_index_type type. */
4074 size_of_string_in_bytes (int kind, tree string_length)
4077 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
4079 bytesize = build_int_cst (gfc_array_index_type,
4080 gfc_character_kinds[i].bit_size / 8);
4082 return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
4083 fold_convert (gfc_array_index_type, string_length));
4088 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
4101 arg = expr->value.function.actual->expr;
4103 gfc_init_se (&argse, NULL);
4104 ss = gfc_walk_expr (arg);
4106 if (ss == gfc_ss_terminator)
4108 gfc_conv_expr_reference (&argse, arg);
4109 source = argse.expr;
4111 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4114 /* Obtain the source word length. */
4115 if (arg->ts.type == BT_CHARACTER)
4116 se->expr = size_of_string_in_bytes (arg->ts.kind,
4117 argse.string_length);
4119 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
4123 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
4124 argse.want_pointer = 0;
4125 gfc_conv_expr_descriptor (&argse, arg, ss);
4126 source = gfc_conv_descriptor_data_get (argse.expr);
4127 type = gfc_get_element_type (TREE_TYPE (argse.expr));
4129 /* Obtain the argument's word length. */
4130 if (arg->ts.type == BT_CHARACTER)
4131 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4133 tmp = fold_convert (gfc_array_index_type,
4134 size_in_bytes (type));
4135 gfc_add_modify (&argse.pre, source_bytes, tmp);
4137 /* Obtain the size of the array in bytes. */
4138 for (n = 0; n < arg->rank; n++)
4141 idx = gfc_rank_cst[n];
4142 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4143 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4144 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4146 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4147 tmp, gfc_index_one_node);
4148 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4150 gfc_add_modify (&argse.pre, source_bytes, tmp);
4152 se->expr = source_bytes;
4155 gfc_add_block_to_block (&se->pre, &argse.pre);
4159 /* Intrinsic string comparison functions. */
4162 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
4166 gfc_conv_intrinsic_function_args (se, expr, args, 4);
4169 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
4170 expr->value.function.actual->expr->ts.kind);
4171 se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
4172 build_int_cst (TREE_TYPE (se->expr), 0));
4175 /* Generate a call to the adjustl/adjustr library function. */
4177 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
4185 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
4188 type = TREE_TYPE (args[2]);
4189 var = gfc_conv_string_tmp (se, type, len);
4192 tmp = build_call_expr_loc (input_location,
4193 fndecl, 3, args[0], args[1], args[2]);
4194 gfc_add_expr_to_block (&se->pre, tmp);
4196 se->string_length = len;
4200 /* Generate code for the TRANSFER intrinsic:
4202 DEST = TRANSFER (SOURCE, MOLD)
4204 typeof<DEST> = typeof<MOLD>
4209 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4211 typeof<DEST> = typeof<MOLD>
4213 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4214 sizeof (DEST(0) * SIZE). */
4216 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
4233 gfc_actual_arglist *arg;
4243 info = &se->ss->data.info;
4245 /* Convert SOURCE. The output from this stage is:-
4246 source_bytes = length of the source in bytes
4247 source = pointer to the source data. */
4248 arg = expr->value.function.actual;
4250 /* Ensure double transfer through LOGICAL preserves all
4252 if (arg->expr->expr_type == EXPR_FUNCTION
4253 && arg->expr->value.function.esym == NULL
4254 && arg->expr->value.function.isym != NULL
4255 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4256 && arg->expr->ts.type == BT_LOGICAL
4257 && expr->ts.type != arg->expr->ts.type)
4258 arg->expr->value.function.name = "__transfer_in_transfer";
4260 gfc_init_se (&argse, NULL);
4261 ss = gfc_walk_expr (arg->expr);
4263 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4265 /* Obtain the pointer to source and the length of source in bytes. */
4266 if (ss == gfc_ss_terminator)
4268 gfc_conv_expr_reference (&argse, arg->expr);
4269 source = argse.expr;
4271 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4274 /* Obtain the source word length. */
4275 if (arg->expr->ts.type == BT_CHARACTER)
4276 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4277 argse.string_length);
4279 tmp = fold_convert (gfc_array_index_type,
4280 size_in_bytes (source_type));
4284 argse.want_pointer = 0;
4285 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4286 source = gfc_conv_descriptor_data_get (argse.expr);
4287 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4289 /* Repack the source if not a full variable array. */
4290 if (arg->expr->expr_type == EXPR_VARIABLE
4291 && arg->expr->ref->u.ar.type != AR_FULL)
4293 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4295 if (gfc_option.warn_array_temp)
4296 gfc_warning ("Creating array temporary at %L", &expr->where);
4298 source = build_call_expr_loc (input_location,
4299 gfor_fndecl_in_pack, 1, tmp);
4300 source = gfc_evaluate_now (source, &argse.pre);
4302 /* Free the temporary. */
4303 gfc_start_block (&block);
4304 tmp = gfc_call_free (convert (pvoid_type_node, source));
4305 gfc_add_expr_to_block (&block, tmp);
4306 stmt = gfc_finish_block (&block);
4308 /* Clean up if it was repacked. */
4309 gfc_init_block (&block);
4310 tmp = gfc_conv_array_data (argse.expr);
4311 tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
4312 tmp = build3_v (COND_EXPR, tmp, stmt,
4313 build_empty_stmt (input_location));
4314 gfc_add_expr_to_block (&block, tmp);
4315 gfc_add_block_to_block (&block, &se->post);
4316 gfc_init_block (&se->post);
4317 gfc_add_block_to_block (&se->post, &block);
4320 /* Obtain the source word length. */
4321 if (arg->expr->ts.type == BT_CHARACTER)
4322 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4323 argse.string_length);
4325 tmp = fold_convert (gfc_array_index_type,
4326 size_in_bytes (source_type));
4328 /* Obtain the size of the array in bytes. */
4329 extent = gfc_create_var (gfc_array_index_type, NULL);
4330 for (n = 0; n < arg->expr->rank; n++)
4333 idx = gfc_rank_cst[n];
4334 gfc_add_modify (&argse.pre, source_bytes, tmp);
4335 stride = gfc_conv_descriptor_stride_get (argse.expr, idx);
4336 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4337 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4338 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4340 gfc_add_modify (&argse.pre, extent, tmp);
4341 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4342 extent, gfc_index_one_node);
4343 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4348 gfc_add_modify (&argse.pre, source_bytes, tmp);
4349 gfc_add_block_to_block (&se->pre, &argse.pre);
4350 gfc_add_block_to_block (&se->post, &argse.post);
4352 /* Now convert MOLD. The outputs are:
4353 mold_type = the TREE type of MOLD
4354 dest_word_len = destination word length in bytes. */
4357 gfc_init_se (&argse, NULL);
4358 ss = gfc_walk_expr (arg->expr);
4360 scalar_mold = arg->expr->rank == 0;
4362 if (ss == gfc_ss_terminator)
4364 gfc_conv_expr_reference (&argse, arg->expr);
4365 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4370 gfc_init_se (&argse, NULL);
4371 argse.want_pointer = 0;
4372 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4373 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4376 gfc_add_block_to_block (&se->pre, &argse.pre);
4377 gfc_add_block_to_block (&se->post, &argse.post);
4379 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4381 /* If this TRANSFER is nested in another TRANSFER, use a type
4382 that preserves all bits. */
4383 if (arg->expr->ts.type == BT_LOGICAL)
4384 mold_type = gfc_get_int_type (arg->expr->ts.kind);
4387 if (arg->expr->ts.type == BT_CHARACTER)
4389 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4390 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4393 tmp = fold_convert (gfc_array_index_type,
4394 size_in_bytes (mold_type));
4396 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4397 gfc_add_modify (&se->pre, dest_word_len, tmp);
4399 /* Finally convert SIZE, if it is present. */
4401 size_words = gfc_create_var (gfc_array_index_type, NULL);
4405 gfc_init_se (&argse, NULL);
4406 gfc_conv_expr_reference (&argse, arg->expr);
4407 tmp = convert (gfc_array_index_type,
4408 build_fold_indirect_ref_loc (input_location,
4410 gfc_add_block_to_block (&se->pre, &argse.pre);
4411 gfc_add_block_to_block (&se->post, &argse.post);
4416 /* Separate array and scalar results. */
4417 if (scalar_mold && tmp == NULL_TREE)
4418 goto scalar_transfer;
4420 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4421 if (tmp != NULL_TREE)
4422 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4423 tmp, dest_word_len);
4427 gfc_add_modify (&se->pre, size_bytes, tmp);
4428 gfc_add_modify (&se->pre, size_words,
4429 fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
4430 size_bytes, dest_word_len));
4432 /* Evaluate the bounds of the result. If the loop range exists, we have
4433 to check if it is too large. If so, we modify loop->to be consistent
4434 with min(size, size(source)). Otherwise, size is made consistent with
4435 the loop range, so that the right number of bytes is transferred.*/
4436 n = se->loop->order[0];
4437 if (se->loop->to[n] != NULL_TREE)
4439 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4440 se->loop->to[n], se->loop->from[n]);
4441 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4442 tmp, gfc_index_one_node);
4443 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
4445 gfc_add_modify (&se->pre, size_words, tmp);
4446 gfc_add_modify (&se->pre, size_bytes,
4447 fold_build2 (MULT_EXPR, gfc_array_index_type,
4448 size_words, dest_word_len));
4449 upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4450 size_words, se->loop->from[n]);
4451 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4452 upper, gfc_index_one_node);
4456 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4457 size_words, gfc_index_one_node);
4458 se->loop->from[n] = gfc_index_zero_node;
4461 se->loop->to[n] = upper;
4463 /* Build a destination descriptor, using the pointer, source, as the
4465 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4466 info, mold_type, NULL_TREE, false, true, false,
4469 /* Cast the pointer to the result. */
4470 tmp = gfc_conv_descriptor_data_get (info->descriptor);
4471 tmp = fold_convert (pvoid_type_node, tmp);
4473 /* Use memcpy to do the transfer. */
4474 tmp = build_call_expr_loc (input_location,
4475 built_in_decls[BUILT_IN_MEMCPY],
4478 fold_convert (pvoid_type_node, source),
4479 fold_build2 (MIN_EXPR, gfc_array_index_type,
4480 size_bytes, source_bytes));
4481 gfc_add_expr_to_block (&se->pre, tmp);
4483 se->expr = info->descriptor;
4484 if (expr->ts.type == BT_CHARACTER)
4485 se->string_length = dest_word_len;
4489 /* Deal with scalar results. */
4491 extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
4492 dest_word_len, source_bytes);
4494 if (expr->ts.type == BT_CHARACTER)
4499 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4500 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4503 /* If source is longer than the destination, use a pointer to
4504 the source directly. */
4505 gfc_init_block (&block);
4506 gfc_add_modify (&block, tmpdecl, ptr);
4507 direct = gfc_finish_block (&block);
4509 /* Otherwise, allocate a string with the length of the destination
4510 and copy the source into it. */
4511 gfc_init_block (&block);
4512 tmp = gfc_get_pchar_type (expr->ts.kind);
4513 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4514 gfc_add_modify (&block, tmpdecl,
4515 fold_convert (TREE_TYPE (ptr), tmp));
4516 tmp = build_call_expr_loc (input_location,
4517 built_in_decls[BUILT_IN_MEMCPY], 3,
4518 fold_convert (pvoid_type_node, tmpdecl),
4519 fold_convert (pvoid_type_node, ptr),
4521 gfc_add_expr_to_block (&block, tmp);
4522 indirect = gfc_finish_block (&block);
4524 /* Wrap it up with the condition. */
4525 tmp = fold_build2 (LE_EXPR, boolean_type_node,
4526 dest_word_len, source_bytes);
4527 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4528 gfc_add_expr_to_block (&se->pre, tmp);
4531 se->string_length = dest_word_len;
4535 tmpdecl = gfc_create_var (mold_type, "transfer");
4537 ptr = convert (build_pointer_type (mold_type), source);
4539 /* Use memcpy to do the transfer. */
4540 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4541 tmp = build_call_expr_loc (input_location,
4542 built_in_decls[BUILT_IN_MEMCPY], 3,
4543 fold_convert (pvoid_type_node, tmp),
4544 fold_convert (pvoid_type_node, ptr),
4546 gfc_add_expr_to_block (&se->pre, tmp);
4553 /* Generate code for the ALLOCATED intrinsic.
4554 Generate inline code that directly check the address of the argument. */
4557 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4559 gfc_actual_arglist *arg1;
4564 gfc_init_se (&arg1se, NULL);
4565 arg1 = expr->value.function.actual;
4566 ss1 = gfc_walk_expr (arg1->expr);
4567 arg1se.descriptor_only = 1;
4568 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4570 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4571 tmp = fold_build2 (NE_EXPR, boolean_type_node,
4572 tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4573 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4577 /* Generate code for the ASSOCIATED intrinsic.
4578 If both POINTER and TARGET are arrays, generate a call to library function
4579 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4580 In other cases, generate inline code that directly compare the address of
4581 POINTER with the address of TARGET. */
4584 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4586 gfc_actual_arglist *arg1;
4587 gfc_actual_arglist *arg2;
4592 tree nonzero_charlen;
4593 tree nonzero_arraylen;
4596 gfc_init_se (&arg1se, NULL);
4597 gfc_init_se (&arg2se, NULL);
4598 arg1 = expr->value.function.actual;
4600 ss1 = gfc_walk_expr (arg1->expr);
4604 /* No optional target. */
4605 if (ss1 == gfc_ss_terminator)
4607 /* A pointer to a scalar. */
4608 arg1se.want_pointer = 1;
4609 gfc_conv_expr (&arg1se, arg1->expr);
4614 /* A pointer to an array. */
4615 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4616 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4618 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4619 gfc_add_block_to_block (&se->post, &arg1se.post);
4620 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4621 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4626 /* An optional target. */
4627 ss2 = gfc_walk_expr (arg2->expr);
4629 nonzero_charlen = NULL_TREE;
4630 if (arg1->expr->ts.type == BT_CHARACTER)
4631 nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4632 arg1->expr->ts.cl->backend_decl,
4635 if (ss1 == gfc_ss_terminator)
4637 /* A pointer to a scalar. */
4638 gcc_assert (ss2 == gfc_ss_terminator);
4639 arg1se.want_pointer = 1;
4640 gfc_conv_expr (&arg1se, arg1->expr);
4641 arg2se.want_pointer = 1;
4642 gfc_conv_expr (&arg2se, arg2->expr);
4643 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4644 gfc_add_block_to_block (&se->post, &arg1se.post);
4645 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4646 arg1se.expr, arg2se.expr);
4647 tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4648 arg1se.expr, null_pointer_node);
4649 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4654 /* An array pointer of zero length is not associated if target is
4656 arg1se.descriptor_only = 1;
4657 gfc_conv_expr_lhs (&arg1se, arg1->expr);
4658 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4659 gfc_rank_cst[arg1->expr->rank - 1]);
4660 nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4661 build_int_cst (TREE_TYPE (tmp), 0));
4663 /* A pointer to an array, call library function _gfor_associated. */
4664 gcc_assert (ss2 != gfc_ss_terminator);
4665 arg1se.want_pointer = 1;
4666 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4668 arg2se.want_pointer = 1;
4669 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4670 gfc_add_block_to_block (&se->pre, &arg2se.pre);
4671 gfc_add_block_to_block (&se->post, &arg2se.post);
4672 se->expr = build_call_expr_loc (input_location,
4673 gfor_fndecl_associated, 2,
4674 arg1se.expr, arg2se.expr);
4675 se->expr = convert (boolean_type_node, se->expr);
4676 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4677 se->expr, nonzero_arraylen);
4680 /* If target is present zero character length pointers cannot
4682 if (nonzero_charlen != NULL_TREE)
4683 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4684 se->expr, nonzero_charlen);
4687 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4691 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4694 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4698 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4699 se->expr = build_call_expr_loc (input_location,
4700 gfor_fndecl_sc_kind, 2, args[0], args[1]);
4701 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4705 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4708 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4712 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4714 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4715 type = gfc_get_int_type (4);
4716 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4718 /* Convert it to the required type. */
4719 type = gfc_typenode_for_spec (&expr->ts);
4720 se->expr = build_call_expr_loc (input_location,
4721 gfor_fndecl_si_kind, 1, arg);
4722 se->expr = fold_convert (type, se->expr);
4726 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4729 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4731 gfc_actual_arglist *actual;
4736 for (actual = expr->value.function.actual; actual; actual = actual->next)
4738 gfc_init_se (&argse, se);
4740 /* Pass a NULL pointer for an absent arg. */
4741 if (actual->expr == NULL)
4742 argse.expr = null_pointer_node;
4748 if (actual->expr->ts.kind != gfc_c_int_kind)
4750 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4751 ts.type = BT_INTEGER;
4752 ts.kind = gfc_c_int_kind;
4753 gfc_convert_type (actual->expr, &ts, 2);
4755 gfc_conv_expr_reference (&argse, actual->expr);
4758 gfc_add_block_to_block (&se->pre, &argse.pre);
4759 gfc_add_block_to_block (&se->post, &argse.post);
4760 args = gfc_chainon_list (args, argse.expr);
4763 /* Convert it to the required type. */
4764 type = gfc_typenode_for_spec (&expr->ts);
4765 se->expr = build_function_call_expr (input_location,
4766 gfor_fndecl_sr_kind, args);
4767 se->expr = fold_convert (type, se->expr);
4771 /* Generate code for TRIM (A) intrinsic function. */
4774 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4784 unsigned int num_args;
4786 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4787 args = (tree *) alloca (sizeof (tree) * num_args);
4789 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4790 addr = gfc_build_addr_expr (ppvoid_type_node, var);
4791 len = gfc_create_var (gfc_get_int_type (4), "len");
4793 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4794 args[0] = gfc_build_addr_expr (NULL_TREE, len);
4797 if (expr->ts.kind == 1)
4798 function = gfor_fndecl_string_trim;
4799 else if (expr->ts.kind == 4)
4800 function = gfor_fndecl_string_trim_char4;
4804 fndecl = build_addr (function, current_function_decl);
4805 tmp = build_call_array_loc (input_location,
4806 TREE_TYPE (TREE_TYPE (function)), fndecl,
4808 gfc_add_expr_to_block (&se->pre, tmp);
4810 /* Free the temporary afterwards, if necessary. */
4811 cond = fold_build2 (GT_EXPR, boolean_type_node,
4812 len, build_int_cst (TREE_TYPE (len), 0));
4813 tmp = gfc_call_free (var);
4814 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4815 gfc_add_expr_to_block (&se->post, tmp);
4818 se->string_length = len;
4822 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
4825 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4827 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4828 tree type, cond, tmp, count, exit_label, n, max, largest;
4830 stmtblock_t block, body;
4833 /* We store in charsize the size of a character. */
4834 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4835 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4837 /* Get the arguments. */
4838 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4839 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4841 ncopies = gfc_evaluate_now (args[2], &se->pre);
4842 ncopies_type = TREE_TYPE (ncopies);
4844 /* Check that NCOPIES is not negative. */
4845 cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4846 build_int_cst (ncopies_type, 0));
4847 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4848 "Argument NCOPIES of REPEAT intrinsic is negative "
4849 "(its value is %lld)",
4850 fold_convert (long_integer_type_node, ncopies));
4852 /* If the source length is zero, any non negative value of NCOPIES
4853 is valid, and nothing happens. */
4854 n = gfc_create_var (ncopies_type, "ncopies");
4855 cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4856 build_int_cst (size_type_node, 0));
4857 tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4858 build_int_cst (ncopies_type, 0), ncopies);
4859 gfc_add_modify (&se->pre, n, tmp);
4862 /* Check that ncopies is not too large: ncopies should be less than
4863 (or equal to) MAX / slen, where MAX is the maximal integer of
4864 the gfc_charlen_type_node type. If slen == 0, we need a special
4865 case to avoid the division by zero. */
4866 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4867 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4868 max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4869 fold_convert (size_type_node, max), slen);
4870 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4871 ? size_type_node : ncopies_type;
4872 cond = fold_build2 (GT_EXPR, boolean_type_node,
4873 fold_convert (largest, ncopies),
4874 fold_convert (largest, max));
4875 tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4876 build_int_cst (size_type_node, 0));
4877 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4879 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4880 "Argument NCOPIES of REPEAT intrinsic is too large");
4882 /* Compute the destination length. */
4883 dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4884 fold_convert (gfc_charlen_type_node, slen),
4885 fold_convert (gfc_charlen_type_node, ncopies));
4886 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
4887 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4889 /* Generate the code to do the repeat operation:
4890 for (i = 0; i < ncopies; i++)
4891 memmove (dest + (i * slen * size), src, slen*size); */
4892 gfc_start_block (&block);
4893 count = gfc_create_var (ncopies_type, "count");
4894 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4895 exit_label = gfc_build_label_decl (NULL_TREE);
4897 /* Start the loop body. */
4898 gfc_start_block (&body);
4900 /* Exit the loop if count >= ncopies. */
4901 cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4902 tmp = build1_v (GOTO_EXPR, exit_label);
4903 TREE_USED (exit_label) = 1;
4904 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4905 build_empty_stmt (input_location));
4906 gfc_add_expr_to_block (&body, tmp);
4908 /* Call memmove (dest + (i*slen*size), src, slen*size). */
4909 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4910 fold_convert (gfc_charlen_type_node, slen),
4911 fold_convert (gfc_charlen_type_node, count));
4912 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4913 tmp, fold_convert (gfc_charlen_type_node, size));
4914 tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4915 fold_convert (pvoid_type_node, dest),
4916 fold_convert (sizetype, tmp));
4917 tmp = build_call_expr_loc (input_location,
4918 built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4919 fold_build2 (MULT_EXPR, size_type_node, slen,
4920 fold_convert (size_type_node, size)));
4921 gfc_add_expr_to_block (&body, tmp);
4923 /* Increment count. */
4924 tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4925 count, build_int_cst (TREE_TYPE (count), 1));
4926 gfc_add_modify (&body, count, tmp);
4928 /* Build the loop. */
4929 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4930 gfc_add_expr_to_block (&block, tmp);
4932 /* Add the exit label. */
4933 tmp = build1_v (LABEL_EXPR, exit_label);
4934 gfc_add_expr_to_block (&block, tmp);
4936 /* Finish the block. */
4937 tmp = gfc_finish_block (&block);
4938 gfc_add_expr_to_block (&se->pre, tmp);
4940 /* Set the result value. */
4942 se->string_length = dlen;
4946 /* Generate code for the IARGC intrinsic. */
4949 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4955 /* Call the library function. This always returns an INTEGER(4). */
4956 fndecl = gfor_fndecl_iargc;
4957 tmp = build_call_expr_loc (input_location,
4960 /* Convert it to the required type. */
4961 type = gfc_typenode_for_spec (&expr->ts);
4962 tmp = fold_convert (type, tmp);
4968 /* The loc intrinsic returns the address of its argument as
4969 gfc_index_integer_kind integer. */
4972 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4978 gcc_assert (!se->ss);
4980 arg_expr = expr->value.function.actual->expr;
4981 ss = gfc_walk_expr (arg_expr);
4982 if (ss == gfc_ss_terminator)
4983 gfc_conv_expr_reference (se, arg_expr);
4985 gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
4986 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4988 /* Create a temporary variable for loc return value. Without this,
4989 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4990 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4991 gfc_add_modify (&se->pre, temp_var, se->expr);
4992 se->expr = temp_var;
4995 /* Generate code for an intrinsic function. Some map directly to library
4996 calls, others get special handling. In some cases the name of the function
4997 used depends on the type specifiers. */
5000 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
5002 gfc_intrinsic_sym *isym;
5007 isym = expr->value.function.isym;
5009 name = &expr->value.function.name[2];
5011 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
5013 lib = gfc_is_intrinsic_libcall (expr);
5017 se->ignore_optional = 1;
5019 switch (expr->value.function.isym->id)
5021 case GFC_ISYM_EOSHIFT:
5023 case GFC_ISYM_RESHAPE:
5024 /* For all of those the first argument specifies the type and the
5025 third is optional. */
5026 conv_generic_with_optional_char_arg (se, expr, 1, 3);
5030 gfc_conv_intrinsic_funcall (se, expr);
5038 switch (expr->value.function.isym->id)
5043 case GFC_ISYM_REPEAT:
5044 gfc_conv_intrinsic_repeat (se, expr);
5048 gfc_conv_intrinsic_trim (se, expr);
5051 case GFC_ISYM_SC_KIND:
5052 gfc_conv_intrinsic_sc_kind (se, expr);
5055 case GFC_ISYM_SI_KIND:
5056 gfc_conv_intrinsic_si_kind (se, expr);
5059 case GFC_ISYM_SR_KIND:
5060 gfc_conv_intrinsic_sr_kind (se, expr);
5063 case GFC_ISYM_EXPONENT:
5064 gfc_conv_intrinsic_exponent (se, expr);
5068 kind = expr->value.function.actual->expr->ts.kind;
5070 fndecl = gfor_fndecl_string_scan;
5072 fndecl = gfor_fndecl_string_scan_char4;
5076 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5079 case GFC_ISYM_VERIFY:
5080 kind = expr->value.function.actual->expr->ts.kind;
5082 fndecl = gfor_fndecl_string_verify;
5084 fndecl = gfor_fndecl_string_verify_char4;
5088 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5091 case GFC_ISYM_ALLOCATED:
5092 gfc_conv_allocated (se, expr);
5095 case GFC_ISYM_ASSOCIATED:
5096 gfc_conv_associated(se, expr);
5100 gfc_conv_intrinsic_abs (se, expr);
5103 case GFC_ISYM_ADJUSTL:
5104 if (expr->ts.kind == 1)
5105 fndecl = gfor_fndecl_adjustl;
5106 else if (expr->ts.kind == 4)
5107 fndecl = gfor_fndecl_adjustl_char4;
5111 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5114 case GFC_ISYM_ADJUSTR:
5115 if (expr->ts.kind == 1)
5116 fndecl = gfor_fndecl_adjustr;
5117 else if (expr->ts.kind == 4)
5118 fndecl = gfor_fndecl_adjustr_char4;
5122 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5125 case GFC_ISYM_AIMAG:
5126 gfc_conv_intrinsic_imagpart (se, expr);
5130 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
5134 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
5137 case GFC_ISYM_ANINT:
5138 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
5142 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5146 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
5149 case GFC_ISYM_BTEST:
5150 gfc_conv_intrinsic_btest (se, expr);
5153 case GFC_ISYM_ACHAR:
5155 gfc_conv_intrinsic_char (se, expr);
5158 case GFC_ISYM_CONVERSION:
5160 case GFC_ISYM_LOGICAL:
5162 gfc_conv_intrinsic_conversion (se, expr);
5165 /* Integer conversions are handled separately to make sure we get the
5166 correct rounding mode. */
5171 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5175 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5178 case GFC_ISYM_CEILING:
5179 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5182 case GFC_ISYM_FLOOR:
5183 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5187 gfc_conv_intrinsic_mod (se, expr, 0);
5190 case GFC_ISYM_MODULO:
5191 gfc_conv_intrinsic_mod (se, expr, 1);
5194 case GFC_ISYM_CMPLX:
5195 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5198 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5199 gfc_conv_intrinsic_iargc (se, expr);
5202 case GFC_ISYM_COMPLEX:
5203 gfc_conv_intrinsic_cmplx (se, expr, 1);
5206 case GFC_ISYM_CONJG:
5207 gfc_conv_intrinsic_conjg (se, expr);
5210 case GFC_ISYM_COUNT:
5211 gfc_conv_intrinsic_count (se, expr);
5214 case GFC_ISYM_CTIME:
5215 gfc_conv_intrinsic_ctime (se, expr);
5219 gfc_conv_intrinsic_dim (se, expr);
5222 case GFC_ISYM_DOT_PRODUCT:
5223 gfc_conv_intrinsic_dot_product (se, expr);
5226 case GFC_ISYM_DPROD:
5227 gfc_conv_intrinsic_dprod (se, expr);
5230 case GFC_ISYM_FDATE:
5231 gfc_conv_intrinsic_fdate (se, expr);
5234 case GFC_ISYM_FRACTION:
5235 gfc_conv_intrinsic_fraction (se, expr);
5239 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5242 case GFC_ISYM_IBCLR:
5243 gfc_conv_intrinsic_singlebitop (se, expr, 0);
5246 case GFC_ISYM_IBITS:
5247 gfc_conv_intrinsic_ibits (se, expr);
5250 case GFC_ISYM_IBSET:
5251 gfc_conv_intrinsic_singlebitop (se, expr, 1);
5254 case GFC_ISYM_IACHAR:
5255 case GFC_ISYM_ICHAR:
5256 /* We assume ASCII character sequence. */
5257 gfc_conv_intrinsic_ichar (se, expr);
5260 case GFC_ISYM_IARGC:
5261 gfc_conv_intrinsic_iargc (se, expr);
5265 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5268 case GFC_ISYM_INDEX:
5269 kind = expr->value.function.actual->expr->ts.kind;
5271 fndecl = gfor_fndecl_string_index;
5273 fndecl = gfor_fndecl_string_index_char4;
5277 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5281 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5284 case GFC_ISYM_IS_IOSTAT_END:
5285 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5288 case GFC_ISYM_IS_IOSTAT_EOR:
5289 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5292 case GFC_ISYM_ISNAN:
5293 gfc_conv_intrinsic_isnan (se, expr);
5296 case GFC_ISYM_LSHIFT:
5297 gfc_conv_intrinsic_rlshift (se, expr, 0);
5300 case GFC_ISYM_RSHIFT:
5301 gfc_conv_intrinsic_rlshift (se, expr, 1);
5304 case GFC_ISYM_ISHFT:
5305 gfc_conv_intrinsic_ishft (se, expr);
5308 case GFC_ISYM_ISHFTC:
5309 gfc_conv_intrinsic_ishftc (se, expr);
5312 case GFC_ISYM_LEADZ:
5313 gfc_conv_intrinsic_leadz (se, expr);
5316 case GFC_ISYM_TRAILZ:
5317 gfc_conv_intrinsic_trailz (se, expr);
5320 case GFC_ISYM_LBOUND:
5321 gfc_conv_intrinsic_bound (se, expr, 0);
5324 case GFC_ISYM_TRANSPOSE:
5325 if (se->ss && se->ss->useflags)
5327 gfc_conv_tmp_array_ref (se);
5328 gfc_advance_se_ss_chain (se);
5331 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5335 gfc_conv_intrinsic_len (se, expr);
5338 case GFC_ISYM_LEN_TRIM:
5339 gfc_conv_intrinsic_len_trim (se, expr);
5343 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5347 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5351 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5355 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5359 if (expr->ts.type == BT_CHARACTER)
5360 gfc_conv_intrinsic_minmax_char (se, expr, 1);
5362 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5365 case GFC_ISYM_MAXLOC:
5366 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5369 case GFC_ISYM_MAXVAL:
5370 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5373 case GFC_ISYM_MERGE:
5374 gfc_conv_intrinsic_merge (se, expr);
5378 if (expr->ts.type == BT_CHARACTER)
5379 gfc_conv_intrinsic_minmax_char (se, expr, -1);
5381 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5384 case GFC_ISYM_MINLOC:
5385 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5388 case GFC_ISYM_MINVAL:
5389 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5392 case GFC_ISYM_NEAREST:
5393 gfc_conv_intrinsic_nearest (se, expr);
5397 gfc_conv_intrinsic_not (se, expr);
5401 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5404 case GFC_ISYM_PRESENT:
5405 gfc_conv_intrinsic_present (se, expr);
5408 case GFC_ISYM_PRODUCT:
5409 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
5412 case GFC_ISYM_RRSPACING:
5413 gfc_conv_intrinsic_rrspacing (se, expr);
5416 case GFC_ISYM_SET_EXPONENT:
5417 gfc_conv_intrinsic_set_exponent (se, expr);
5420 case GFC_ISYM_SCALE:
5421 gfc_conv_intrinsic_scale (se, expr);
5425 gfc_conv_intrinsic_sign (se, expr);
5429 gfc_conv_intrinsic_size (se, expr);
5432 case GFC_ISYM_SIZEOF:
5433 gfc_conv_intrinsic_sizeof (se, expr);
5436 case GFC_ISYM_SPACING:
5437 gfc_conv_intrinsic_spacing (se, expr);
5441 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
5444 case GFC_ISYM_TRANSFER:
5445 if (se->ss && se->ss->useflags)
5447 /* Access the previously obtained result. */
5448 gfc_conv_tmp_array_ref (se);
5449 gfc_advance_se_ss_chain (se);
5452 gfc_conv_intrinsic_transfer (se, expr);
5455 case GFC_ISYM_TTYNAM:
5456 gfc_conv_intrinsic_ttynam (se, expr);
5459 case GFC_ISYM_UBOUND:
5460 gfc_conv_intrinsic_bound (se, expr, 1);
5464 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5468 gfc_conv_intrinsic_loc (se, expr);
5471 case GFC_ISYM_ACCESS:
5472 case GFC_ISYM_CHDIR:
5473 case GFC_ISYM_CHMOD:
5474 case GFC_ISYM_DTIME:
5475 case GFC_ISYM_ETIME:
5477 case GFC_ISYM_FGETC:
5480 case GFC_ISYM_FPUTC:
5481 case GFC_ISYM_FSTAT:
5482 case GFC_ISYM_FTELL:
5483 case GFC_ISYM_GETCWD:
5484 case GFC_ISYM_GETGID:
5485 case GFC_ISYM_GETPID:
5486 case GFC_ISYM_GETUID:
5487 case GFC_ISYM_HOSTNM:
5489 case GFC_ISYM_IERRNO:
5490 case GFC_ISYM_IRAND:
5491 case GFC_ISYM_ISATTY:
5493 case GFC_ISYM_LSTAT:
5494 case GFC_ISYM_MALLOC:
5495 case GFC_ISYM_MATMUL:
5496 case GFC_ISYM_MCLOCK:
5497 case GFC_ISYM_MCLOCK8:
5499 case GFC_ISYM_RENAME:
5500 case GFC_ISYM_SECOND:
5501 case GFC_ISYM_SECNDS:
5502 case GFC_ISYM_SIGNAL:
5504 case GFC_ISYM_SYMLNK:
5505 case GFC_ISYM_SYSTEM:
5507 case GFC_ISYM_TIME8:
5508 case GFC_ISYM_UMASK:
5509 case GFC_ISYM_UNLINK:
5510 gfc_conv_intrinsic_funcall (se, expr);
5513 case GFC_ISYM_EOSHIFT:
5515 case GFC_ISYM_RESHAPE:
5516 /* For those, expr->rank should always be >0 and thus the if above the
5517 switch should have matched. */
5522 gfc_conv_intrinsic_lib_function (se, expr);
5528 /* This generates code to execute before entering the scalarization loop.
5529 Currently does nothing. */
5532 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5534 switch (ss->expr->value.function.isym->id)
5536 case GFC_ISYM_UBOUND:
5537 case GFC_ISYM_LBOUND:
5546 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5547 inside the scalarization loop. */
5550 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5554 /* The two argument version returns a scalar. */
5555 if (expr->value.function.actual->next->expr)
5558 newss = gfc_get_ss ();
5559 newss->type = GFC_SS_INTRINSIC;
5562 newss->data.info.dimen = 1;
5568 /* Walk an intrinsic array libcall. */
5571 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5575 gcc_assert (expr->rank > 0);
5577 newss = gfc_get_ss ();
5578 newss->type = GFC_SS_FUNCTION;
5581 newss->data.info.dimen = expr->rank;
5587 /* Returns nonzero if the specified intrinsic function call maps directly to
5588 an external library call. Should only be used for functions that return
5592 gfc_is_intrinsic_libcall (gfc_expr * expr)
5594 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5595 gcc_assert (expr->rank > 0);
5597 switch (expr->value.function.isym->id)
5601 case GFC_ISYM_COUNT:
5602 case GFC_ISYM_MATMUL:
5603 case GFC_ISYM_MAXLOC:
5604 case GFC_ISYM_MAXVAL:
5605 case GFC_ISYM_MINLOC:
5606 case GFC_ISYM_MINVAL:
5607 case GFC_ISYM_PRODUCT:
5609 case GFC_ISYM_SHAPE:
5610 case GFC_ISYM_SPREAD:
5611 case GFC_ISYM_TRANSPOSE:
5612 /* Ignore absent optional parameters. */
5615 case GFC_ISYM_RESHAPE:
5616 case GFC_ISYM_CSHIFT:
5617 case GFC_ISYM_EOSHIFT:
5619 case GFC_ISYM_UNPACK:
5620 /* Pass absent optional parameters. */
5628 /* Walk an intrinsic function. */
5630 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5631 gfc_intrinsic_sym * isym)
5635 if (isym->elemental)
5636 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5638 if (expr->rank == 0)
5641 if (gfc_is_intrinsic_libcall (expr))
5642 return gfc_walk_intrinsic_libfunc (ss, expr);
5644 /* Special cases. */
5647 case GFC_ISYM_LBOUND:
5648 case GFC_ISYM_UBOUND:
5649 return gfc_walk_intrinsic_bound (ss, expr);
5651 case GFC_ISYM_TRANSFER:
5652 return gfc_walk_intrinsic_libfunc (ss, expr);
5655 /* This probably meant someone forgot to add an intrinsic to the above
5656 list(s) when they implemented it, or something's gone horribly
5662 #include "gt-fortran-trans-intrinsic.h"