1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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, cond3, cond4, size;
842 arg = expr->value.function.actual;
847 /* Create an implicit second parameter from the loop variable. */
848 gcc_assert (!arg2->expr);
849 gcc_assert (se->loop->dimen == 1);
850 gcc_assert (se->ss->expr == expr);
851 gfc_advance_se_ss_chain (se);
852 bound = se->loop->loopvar[0];
853 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
858 /* use the passed argument. */
859 gcc_assert (arg->next->expr);
860 gfc_init_se (&argse, NULL);
861 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
862 gfc_add_block_to_block (&se->pre, &argse.pre);
864 /* Convert from one based to zero based. */
865 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
869 /* TODO: don't re-evaluate the descriptor on each iteration. */
870 /* Get a descriptor for the first parameter. */
871 ss = gfc_walk_expr (arg->expr);
872 gcc_assert (ss != gfc_ss_terminator);
873 gfc_init_se (&argse, NULL);
874 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
875 gfc_add_block_to_block (&se->pre, &argse.pre);
876 gfc_add_block_to_block (&se->post, &argse.post);
880 if (INTEGER_CST_P (bound))
884 hi = TREE_INT_CST_HIGH (bound);
885 low = TREE_INT_CST_LOW (bound);
886 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
887 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
888 "dimension index", upper ? "UBOUND" : "LBOUND",
893 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
895 bound = gfc_evaluate_now (bound, &se->pre);
896 cond = fold_build2 (LT_EXPR, boolean_type_node,
897 bound, build_int_cst (TREE_TYPE (bound), 0));
898 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
899 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
900 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
901 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
906 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
907 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
909 as = gfc_get_full_arrayspec_from_expr (arg->expr);
911 /* 13.14.53: Result value for LBOUND
913 Case (i): For an array section or for an array expression other than a
914 whole array or array structure component, LBOUND(ARRAY, DIM)
915 has the value 1. For a whole array or array structure
916 component, LBOUND(ARRAY, DIM) has the value:
917 (a) equal to the lower bound for subscript DIM of ARRAY if
918 dimension DIM of ARRAY does not have extent zero
919 or if ARRAY is an assumed-size array of rank DIM,
922 13.14.113: Result value for UBOUND
924 Case (i): For an array section or for an array expression other than a
925 whole array or array structure component, UBOUND(ARRAY, DIM)
926 has the value equal to the number of elements in the given
927 dimension; otherwise, it has a value equal to the upper bound
928 for subscript DIM of ARRAY if dimension DIM of ARRAY does
929 not have size zero and has value zero if dimension DIM has
934 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
936 cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
938 cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
939 gfc_index_zero_node);
940 cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
942 cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
943 gfc_index_zero_node);
948 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
950 cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
951 cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
953 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
955 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
956 ubound, gfc_index_zero_node);
960 if (as->type == AS_ASSUMED_SIZE)
961 cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
962 build_int_cst (TREE_TYPE (bound),
963 arg->expr->rank - 1));
965 cond = boolean_false_node;
967 cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
968 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
970 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
971 lbound, gfc_index_one_node);
978 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
979 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
981 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
982 gfc_index_zero_node);
985 se->expr = gfc_index_one_node;
988 type = gfc_typenode_for_spec (&expr->ts);
989 se->expr = convert (type, se->expr);
994 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
999 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1001 switch (expr->value.function.actual->expr->ts.type)
1005 se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1009 switch (expr->ts.kind)
1024 se->expr = build_call_expr_loc (input_location,
1025 built_in_decls[n], 1, arg);
1034 /* Create a complex value from one or two real components. */
1037 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1043 unsigned int num_args;
1045 num_args = gfc_intrinsic_argument_list_length (expr);
1046 args = (tree *) alloca (sizeof (tree) * num_args);
1048 type = gfc_typenode_for_spec (&expr->ts);
1049 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1050 real = convert (TREE_TYPE (type), args[0]);
1052 imag = convert (TREE_TYPE (type), args[1]);
1053 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1055 imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1057 imag = convert (TREE_TYPE (type), imag);
1060 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1062 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1065 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1066 MODULO(A, P) = A - FLOOR (A / P) * P */
1067 /* TODO: MOD(x, 0) */
1070 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1081 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1083 switch (expr->ts.type)
1086 /* Integer case is easy, we've got a builtin op. */
1087 type = TREE_TYPE (args[0]);
1090 se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1092 se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1097 /* Check if we have a builtin fmod. */
1098 switch (expr->ts.kind)
1117 /* Use it if it exists. */
1118 if (n != END_BUILTINS)
1120 tmp = build_addr (built_in_decls[n], current_function_decl);
1121 se->expr = build_call_array_loc (input_location,
1122 TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1128 type = TREE_TYPE (args[0]);
1130 args[0] = gfc_evaluate_now (args[0], &se->pre);
1131 args[1] = gfc_evaluate_now (args[1], &se->pre);
1134 modulo = arg - floor (arg/arg2) * arg2, so
1135 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1137 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1138 thereby avoiding another division and retaining the accuracy
1139 of the builtin function. */
1140 if (n != END_BUILTINS && modulo)
1142 tree zero = gfc_build_const (type, integer_zero_node);
1143 tmp = gfc_evaluate_now (se->expr, &se->pre);
1144 test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1145 test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1146 test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1147 test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1148 test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1149 test = gfc_evaluate_now (test, &se->pre);
1150 se->expr = fold_build3 (COND_EXPR, type, test,
1151 fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1156 /* If we do not have a built_in fmod, the calculation is going to
1157 have to be done longhand. */
1158 tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1160 /* Test if the value is too large to handle sensibly. */
1161 gfc_set_model_kind (expr->ts.kind);
1163 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1164 ikind = expr->ts.kind;
1167 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1168 ikind = gfc_max_integer_kind;
1170 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1171 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1172 test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1174 mpfr_neg (huge, huge, GFC_RND_MODE);
1175 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1176 test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1177 test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1179 itype = gfc_get_int_type (ikind);
1181 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1183 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1184 tmp = convert (type, tmp);
1185 tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1186 tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1187 se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1196 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1199 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1207 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1208 type = TREE_TYPE (args[0]);
1210 val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1211 val = gfc_evaluate_now (val, &se->pre);
1213 zero = gfc_build_const (type, integer_zero_node);
1214 tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1215 se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1219 /* SIGN(A, B) is absolute value of A times sign of B.
1220 The real value versions use library functions to ensure the correct
1221 handling of negative zero. Integer case implemented as:
1222 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1226 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1232 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1233 if (expr->ts.type == BT_REAL)
1237 switch (expr->ts.kind)
1240 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1241 abs = built_in_decls[BUILT_IN_FABSF];
1244 tmp = built_in_decls[BUILT_IN_COPYSIGN];
1245 abs = built_in_decls[BUILT_IN_FABS];
1249 tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1250 abs = built_in_decls[BUILT_IN_FABSL];
1256 /* We explicitly have to ignore the minus sign. We do so by using
1257 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1258 if (!gfc_option.flag_sign_zero
1259 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1262 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1263 cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
1264 se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
1265 build_call_expr (abs, 1, args[0]),
1266 build_call_expr (tmp, 2, args[0], args[1]));
1269 se->expr = build_call_expr_loc (input_location,
1270 tmp, 2, args[0], args[1]);
1274 /* Having excluded floating point types, we know we are now dealing
1275 with signed integer types. */
1276 type = TREE_TYPE (args[0]);
1278 /* Args[0] is used multiple times below. */
1279 args[0] = gfc_evaluate_now (args[0], &se->pre);
1281 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1282 the signs of A and B are the same, and of all ones if they differ. */
1283 tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1284 tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1285 build_int_cst (type, TYPE_PRECISION (type) - 1));
1286 tmp = gfc_evaluate_now (tmp, &se->pre);
1288 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1289 is all ones (i.e. -1). */
1290 se->expr = fold_build2 (BIT_XOR_EXPR, type,
1291 fold_build2 (PLUS_EXPR, type, args[0], tmp),
1296 /* Test for the presence of an optional argument. */
1299 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1303 arg = expr->value.function.actual->expr;
1304 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1305 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1306 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1310 /* Calculate the double precision product of two single precision values. */
1313 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1318 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1320 /* Convert the args to double precision before multiplying. */
1321 type = gfc_typenode_for_spec (&expr->ts);
1322 args[0] = convert (type, args[0]);
1323 args[1] = convert (type, args[1]);
1324 se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1328 /* Return a length one character string containing an ascii character. */
1331 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1336 unsigned int num_args;
1338 num_args = gfc_intrinsic_argument_list_length (expr);
1339 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1341 type = gfc_get_char_type (expr->ts.kind);
1342 var = gfc_create_var (type, "char");
1344 arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1345 gfc_add_modify (&se->pre, var, arg[0]);
1346 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1347 se->string_length = integer_one_node;
1352 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1360 unsigned int num_args;
1362 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1363 args = (tree *) alloca (sizeof (tree) * num_args);
1365 var = gfc_create_var (pchar_type_node, "pstr");
1366 len = gfc_create_var (gfc_get_int_type (8), "len");
1368 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1369 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1370 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1372 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1373 tmp = build_call_array_loc (input_location,
1374 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1375 fndecl, num_args, args);
1376 gfc_add_expr_to_block (&se->pre, tmp);
1378 /* Free the temporary afterwards, if necessary. */
1379 cond = fold_build2 (GT_EXPR, boolean_type_node,
1380 len, build_int_cst (TREE_TYPE (len), 0));
1381 tmp = gfc_call_free (var);
1382 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1383 gfc_add_expr_to_block (&se->post, tmp);
1386 se->string_length = len;
1391 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1399 unsigned int num_args;
1401 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1402 args = (tree *) alloca (sizeof (tree) * num_args);
1404 var = gfc_create_var (pchar_type_node, "pstr");
1405 len = gfc_create_var (gfc_get_int_type (4), "len");
1407 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1408 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1409 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1411 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1412 tmp = build_call_array_loc (input_location,
1413 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1414 fndecl, num_args, args);
1415 gfc_add_expr_to_block (&se->pre, tmp);
1417 /* Free the temporary afterwards, if necessary. */
1418 cond = fold_build2 (GT_EXPR, boolean_type_node,
1419 len, build_int_cst (TREE_TYPE (len), 0));
1420 tmp = gfc_call_free (var);
1421 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1422 gfc_add_expr_to_block (&se->post, tmp);
1425 se->string_length = len;
1429 /* Return a character string containing the tty name. */
1432 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1440 unsigned int num_args;
1442 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1443 args = (tree *) alloca (sizeof (tree) * num_args);
1445 var = gfc_create_var (pchar_type_node, "pstr");
1446 len = gfc_create_var (gfc_get_int_type (4), "len");
1448 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1449 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1450 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1452 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1453 tmp = build_call_array_loc (input_location,
1454 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1455 fndecl, num_args, args);
1456 gfc_add_expr_to_block (&se->pre, tmp);
1458 /* Free the temporary afterwards, if necessary. */
1459 cond = fold_build2 (GT_EXPR, boolean_type_node,
1460 len, build_int_cst (TREE_TYPE (len), 0));
1461 tmp = gfc_call_free (var);
1462 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1463 gfc_add_expr_to_block (&se->post, tmp);
1466 se->string_length = len;
1470 /* Get the minimum/maximum value of all the parameters.
1471 minmax (a1, a2, a3, ...)
1474 if (a2 .op. mvar || isnan(mvar))
1476 if (a3 .op. mvar || isnan(mvar))
1483 /* TODO: Mismatching types can occur when specific names are used.
1484 These should be handled during resolution. */
1486 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1494 gfc_actual_arglist *argexpr;
1495 unsigned int i, nargs;
1497 nargs = gfc_intrinsic_argument_list_length (expr);
1498 args = (tree *) alloca (sizeof (tree) * nargs);
1500 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1501 type = gfc_typenode_for_spec (&expr->ts);
1503 argexpr = expr->value.function.actual;
1504 if (TREE_TYPE (args[0]) != type)
1505 args[0] = convert (type, args[0]);
1506 /* Only evaluate the argument once. */
1507 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1508 args[0] = gfc_evaluate_now (args[0], &se->pre);
1510 mvar = gfc_create_var (type, "M");
1511 gfc_add_modify (&se->pre, mvar, args[0]);
1512 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1518 /* Handle absent optional arguments by ignoring the comparison. */
1519 if (argexpr->expr->expr_type == EXPR_VARIABLE
1520 && argexpr->expr->symtree->n.sym->attr.optional
1521 && TREE_CODE (val) == INDIRECT_REF)
1522 cond = fold_build2_loc (input_location,
1523 NE_EXPR, boolean_type_node,
1524 TREE_OPERAND (val, 0),
1525 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1530 /* Only evaluate the argument once. */
1531 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1532 val = gfc_evaluate_now (val, &se->pre);
1535 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1537 tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1539 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1540 __builtin_isnan might be made dependent on that module being loaded,
1541 to help performance of programs that don't rely on IEEE semantics. */
1542 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1544 isnan = build_call_expr_loc (input_location,
1545 built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1546 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1547 fold_convert (boolean_type_node, isnan));
1549 tmp = build3_v (COND_EXPR, tmp, thencase,
1550 build_empty_stmt (input_location));
1552 if (cond != NULL_TREE)
1553 tmp = build3_v (COND_EXPR, cond, tmp,
1554 build_empty_stmt (input_location));
1556 gfc_add_expr_to_block (&se->pre, tmp);
1557 argexpr = argexpr->next;
1563 /* Generate library calls for MIN and MAX intrinsics for character
1566 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1569 tree var, len, fndecl, tmp, cond, function;
1572 nargs = gfc_intrinsic_argument_list_length (expr);
1573 args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1574 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1576 /* Create the result variables. */
1577 len = gfc_create_var (gfc_charlen_type_node, "len");
1578 args[0] = gfc_build_addr_expr (NULL_TREE, len);
1579 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1580 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1581 args[2] = build_int_cst (NULL_TREE, op);
1582 args[3] = build_int_cst (NULL_TREE, nargs / 2);
1584 if (expr->ts.kind == 1)
1585 function = gfor_fndecl_string_minmax;
1586 else if (expr->ts.kind == 4)
1587 function = gfor_fndecl_string_minmax_char4;
1591 /* Make the function call. */
1592 fndecl = build_addr (function, current_function_decl);
1593 tmp = build_call_array_loc (input_location,
1594 TREE_TYPE (TREE_TYPE (function)), fndecl,
1596 gfc_add_expr_to_block (&se->pre, tmp);
1598 /* Free the temporary afterwards, if necessary. */
1599 cond = fold_build2 (GT_EXPR, boolean_type_node,
1600 len, build_int_cst (TREE_TYPE (len), 0));
1601 tmp = gfc_call_free (var);
1602 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1603 gfc_add_expr_to_block (&se->post, tmp);
1606 se->string_length = len;
1610 /* Create a symbol node for this intrinsic. The symbol from the frontend
1611 has the generic name. */
1614 gfc_get_symbol_for_expr (gfc_expr * expr)
1618 /* TODO: Add symbols for intrinsic function to the global namespace. */
1619 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1620 sym = gfc_new_symbol (expr->value.function.name, NULL);
1623 sym->attr.external = 1;
1624 sym->attr.function = 1;
1625 sym->attr.always_explicit = 1;
1626 sym->attr.proc = PROC_INTRINSIC;
1627 sym->attr.flavor = FL_PROCEDURE;
1631 sym->attr.dimension = 1;
1632 sym->as = gfc_get_array_spec ();
1633 sym->as->type = AS_ASSUMED_SHAPE;
1634 sym->as->rank = expr->rank;
1637 /* TODO: proper argument lists for external intrinsics. */
1641 /* Generate a call to an external intrinsic function. */
1643 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1648 gcc_assert (!se->ss || se->ss->expr == expr);
1651 gcc_assert (expr->rank > 0);
1653 gcc_assert (expr->rank == 0);
1655 sym = gfc_get_symbol_for_expr (expr);
1657 /* Calls to libgfortran_matmul need to be appended special arguments,
1658 to be able to call the BLAS ?gemm functions if required and possible. */
1659 append_args = NULL_TREE;
1660 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1661 && sym->ts.type != BT_LOGICAL)
1663 tree cint = gfc_get_int_type (gfc_c_int_kind);
1665 if (gfc_option.flag_external_blas
1666 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1667 && (sym->ts.kind == gfc_default_real_kind
1668 || sym->ts.kind == gfc_default_double_kind))
1672 if (sym->ts.type == BT_REAL)
1674 if (sym->ts.kind == gfc_default_real_kind)
1675 gemm_fndecl = gfor_fndecl_sgemm;
1677 gemm_fndecl = gfor_fndecl_dgemm;
1681 if (sym->ts.kind == gfc_default_real_kind)
1682 gemm_fndecl = gfor_fndecl_cgemm;
1684 gemm_fndecl = gfor_fndecl_zgemm;
1687 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1688 append_args = gfc_chainon_list
1689 (append_args, build_int_cst
1690 (cint, gfc_option.blas_matmul_limit));
1691 append_args = gfc_chainon_list (append_args,
1692 gfc_build_addr_expr (NULL_TREE,
1697 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1698 append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1699 append_args = gfc_chainon_list (append_args, null_pointer_node);
1703 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1708 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1728 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1737 gfc_actual_arglist *actual;
1744 gfc_conv_intrinsic_funcall (se, expr);
1748 actual = expr->value.function.actual;
1749 type = gfc_typenode_for_spec (&expr->ts);
1750 /* Initialize the result. */
1751 resvar = gfc_create_var (type, "test");
1753 tmp = convert (type, boolean_true_node);
1755 tmp = convert (type, boolean_false_node);
1756 gfc_add_modify (&se->pre, resvar, tmp);
1758 /* Walk the arguments. */
1759 arrayss = gfc_walk_expr (actual->expr);
1760 gcc_assert (arrayss != gfc_ss_terminator);
1762 /* Initialize the scalarizer. */
1763 gfc_init_loopinfo (&loop);
1764 exit_label = gfc_build_label_decl (NULL_TREE);
1765 TREE_USED (exit_label) = 1;
1766 gfc_add_ss_to_loop (&loop, arrayss);
1768 /* Initialize the loop. */
1769 gfc_conv_ss_startstride (&loop);
1770 gfc_conv_loop_setup (&loop, &expr->where);
1772 gfc_mark_ss_chain_used (arrayss, 1);
1773 /* Generate the loop body. */
1774 gfc_start_scalarized_body (&loop, &body);
1776 /* If the condition matches then set the return value. */
1777 gfc_start_block (&block);
1779 tmp = convert (type, boolean_false_node);
1781 tmp = convert (type, boolean_true_node);
1782 gfc_add_modify (&block, resvar, tmp);
1784 /* And break out of the loop. */
1785 tmp = build1_v (GOTO_EXPR, exit_label);
1786 gfc_add_expr_to_block (&block, tmp);
1788 found = gfc_finish_block (&block);
1790 /* Check this element. */
1791 gfc_init_se (&arrayse, NULL);
1792 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1793 arrayse.ss = arrayss;
1794 gfc_conv_expr_val (&arrayse, actual->expr);
1796 gfc_add_block_to_block (&body, &arrayse.pre);
1797 tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1798 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1799 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1800 gfc_add_expr_to_block (&body, tmp);
1801 gfc_add_block_to_block (&body, &arrayse.post);
1803 gfc_trans_scalarizing_loops (&loop, &body);
1805 /* Add the exit label. */
1806 tmp = build1_v (LABEL_EXPR, exit_label);
1807 gfc_add_expr_to_block (&loop.pre, tmp);
1809 gfc_add_block_to_block (&se->pre, &loop.pre);
1810 gfc_add_block_to_block (&se->pre, &loop.post);
1811 gfc_cleanup_loop (&loop);
1816 /* COUNT(A) = Number of true elements in A. */
1818 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1825 gfc_actual_arglist *actual;
1831 gfc_conv_intrinsic_funcall (se, expr);
1835 actual = expr->value.function.actual;
1837 type = gfc_typenode_for_spec (&expr->ts);
1838 /* Initialize the result. */
1839 resvar = gfc_create_var (type, "count");
1840 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1842 /* Walk the arguments. */
1843 arrayss = gfc_walk_expr (actual->expr);
1844 gcc_assert (arrayss != gfc_ss_terminator);
1846 /* Initialize the scalarizer. */
1847 gfc_init_loopinfo (&loop);
1848 gfc_add_ss_to_loop (&loop, arrayss);
1850 /* Initialize the loop. */
1851 gfc_conv_ss_startstride (&loop);
1852 gfc_conv_loop_setup (&loop, &expr->where);
1854 gfc_mark_ss_chain_used (arrayss, 1);
1855 /* Generate the loop body. */
1856 gfc_start_scalarized_body (&loop, &body);
1858 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1859 resvar, build_int_cst (TREE_TYPE (resvar), 1));
1860 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1862 gfc_init_se (&arrayse, NULL);
1863 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1864 arrayse.ss = arrayss;
1865 gfc_conv_expr_val (&arrayse, actual->expr);
1866 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1867 build_empty_stmt (input_location));
1869 gfc_add_block_to_block (&body, &arrayse.pre);
1870 gfc_add_expr_to_block (&body, tmp);
1871 gfc_add_block_to_block (&body, &arrayse.post);
1873 gfc_trans_scalarizing_loops (&loop, &body);
1875 gfc_add_block_to_block (&se->pre, &loop.pre);
1876 gfc_add_block_to_block (&se->pre, &loop.post);
1877 gfc_cleanup_loop (&loop);
1882 /* Inline implementation of the sum and product intrinsics. */
1884 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
1892 gfc_actual_arglist *actual;
1897 gfc_expr *arrayexpr;
1902 gfc_conv_intrinsic_funcall (se, expr);
1906 type = gfc_typenode_for_spec (&expr->ts);
1907 /* Initialize the result. */
1908 resvar = gfc_create_var (type, "val");
1909 if (op == PLUS_EXPR)
1910 tmp = gfc_build_const (type, integer_zero_node);
1912 tmp = gfc_build_const (type, integer_one_node);
1914 gfc_add_modify (&se->pre, resvar, tmp);
1916 /* Walk the arguments. */
1917 actual = expr->value.function.actual;
1918 arrayexpr = actual->expr;
1919 arrayss = gfc_walk_expr (arrayexpr);
1920 gcc_assert (arrayss != gfc_ss_terminator);
1922 actual = actual->next->next;
1923 gcc_assert (actual);
1924 maskexpr = actual->expr;
1925 if (maskexpr && maskexpr->rank != 0)
1927 maskss = gfc_walk_expr (maskexpr);
1928 gcc_assert (maskss != gfc_ss_terminator);
1933 /* Initialize the scalarizer. */
1934 gfc_init_loopinfo (&loop);
1935 gfc_add_ss_to_loop (&loop, arrayss);
1937 gfc_add_ss_to_loop (&loop, maskss);
1939 /* Initialize the loop. */
1940 gfc_conv_ss_startstride (&loop);
1941 gfc_conv_loop_setup (&loop, &expr->where);
1943 gfc_mark_ss_chain_used (arrayss, 1);
1945 gfc_mark_ss_chain_used (maskss, 1);
1946 /* Generate the loop body. */
1947 gfc_start_scalarized_body (&loop, &body);
1949 /* If we have a mask, only add this element if the mask is set. */
1952 gfc_init_se (&maskse, NULL);
1953 gfc_copy_loopinfo_to_se (&maskse, &loop);
1955 gfc_conv_expr_val (&maskse, maskexpr);
1956 gfc_add_block_to_block (&body, &maskse.pre);
1958 gfc_start_block (&block);
1961 gfc_init_block (&block);
1963 /* Do the actual summation/product. */
1964 gfc_init_se (&arrayse, NULL);
1965 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1966 arrayse.ss = arrayss;
1967 gfc_conv_expr_val (&arrayse, arrayexpr);
1968 gfc_add_block_to_block (&block, &arrayse.pre);
1970 tmp = fold_build2 (op, type, resvar, arrayse.expr);
1971 gfc_add_modify (&block, resvar, tmp);
1972 gfc_add_block_to_block (&block, &arrayse.post);
1976 /* We enclose the above in if (mask) {...} . */
1977 tmp = gfc_finish_block (&block);
1979 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1980 build_empty_stmt (input_location));
1983 tmp = gfc_finish_block (&block);
1984 gfc_add_expr_to_block (&body, tmp);
1986 gfc_trans_scalarizing_loops (&loop, &body);
1988 /* For a scalar mask, enclose the loop in an if statement. */
1989 if (maskexpr && maskss == NULL)
1991 gfc_init_se (&maskse, NULL);
1992 gfc_conv_expr_val (&maskse, maskexpr);
1993 gfc_init_block (&block);
1994 gfc_add_block_to_block (&block, &loop.pre);
1995 gfc_add_block_to_block (&block, &loop.post);
1996 tmp = gfc_finish_block (&block);
1998 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1999 build_empty_stmt (input_location));
2000 gfc_add_expr_to_block (&block, tmp);
2001 gfc_add_block_to_block (&se->pre, &block);
2005 gfc_add_block_to_block (&se->pre, &loop.pre);
2006 gfc_add_block_to_block (&se->pre, &loop.post);
2009 gfc_cleanup_loop (&loop);
2015 /* Inline implementation of the dot_product intrinsic. This function
2016 is based on gfc_conv_intrinsic_arith (the previous function). */
2018 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2026 gfc_actual_arglist *actual;
2027 gfc_ss *arrayss1, *arrayss2;
2028 gfc_se arrayse1, arrayse2;
2029 gfc_expr *arrayexpr1, *arrayexpr2;
2031 type = gfc_typenode_for_spec (&expr->ts);
2033 /* Initialize the result. */
2034 resvar = gfc_create_var (type, "val");
2035 if (expr->ts.type == BT_LOGICAL)
2036 tmp = build_int_cst (type, 0);
2038 tmp = gfc_build_const (type, integer_zero_node);
2040 gfc_add_modify (&se->pre, resvar, tmp);
2042 /* Walk argument #1. */
2043 actual = expr->value.function.actual;
2044 arrayexpr1 = actual->expr;
2045 arrayss1 = gfc_walk_expr (arrayexpr1);
2046 gcc_assert (arrayss1 != gfc_ss_terminator);
2048 /* Walk argument #2. */
2049 actual = actual->next;
2050 arrayexpr2 = actual->expr;
2051 arrayss2 = gfc_walk_expr (arrayexpr2);
2052 gcc_assert (arrayss2 != gfc_ss_terminator);
2054 /* Initialize the scalarizer. */
2055 gfc_init_loopinfo (&loop);
2056 gfc_add_ss_to_loop (&loop, arrayss1);
2057 gfc_add_ss_to_loop (&loop, arrayss2);
2059 /* Initialize the loop. */
2060 gfc_conv_ss_startstride (&loop);
2061 gfc_conv_loop_setup (&loop, &expr->where);
2063 gfc_mark_ss_chain_used (arrayss1, 1);
2064 gfc_mark_ss_chain_used (arrayss2, 1);
2066 /* Generate the loop body. */
2067 gfc_start_scalarized_body (&loop, &body);
2068 gfc_init_block (&block);
2070 /* Make the tree expression for [conjg(]array1[)]. */
2071 gfc_init_se (&arrayse1, NULL);
2072 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2073 arrayse1.ss = arrayss1;
2074 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2075 if (expr->ts.type == BT_COMPLEX)
2076 arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2077 gfc_add_block_to_block (&block, &arrayse1.pre);
2079 /* Make the tree expression for array2. */
2080 gfc_init_se (&arrayse2, NULL);
2081 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2082 arrayse2.ss = arrayss2;
2083 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2084 gfc_add_block_to_block (&block, &arrayse2.pre);
2086 /* Do the actual product and sum. */
2087 if (expr->ts.type == BT_LOGICAL)
2089 tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2090 tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2094 tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2095 tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2097 gfc_add_modify (&block, resvar, tmp);
2099 /* Finish up the loop block and the loop. */
2100 tmp = gfc_finish_block (&block);
2101 gfc_add_expr_to_block (&body, tmp);
2103 gfc_trans_scalarizing_loops (&loop, &body);
2104 gfc_add_block_to_block (&se->pre, &loop.pre);
2105 gfc_add_block_to_block (&se->pre, &loop.post);
2106 gfc_cleanup_loop (&loop);
2112 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2113 we need to handle. For performance reasons we sometimes create two
2114 loops instead of one, where the second one is much simpler.
2115 Examples for minloc intrinsic:
2116 1) Result is an array, a call is generated
2117 2) Array mask is used and NaNs need to be supported:
2123 if (pos == 0) pos = S + (1 - from);
2124 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2131 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2135 3) NaNs need to be supported, but it is known at compile time or cheaply
2136 at runtime whether array is nonempty or not:
2141 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2144 if (from <= to) pos = 1;
2148 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2152 4) NaNs aren't supported, array mask is used:
2153 limit = infinities_supported ? Infinity : huge (limit);
2157 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2163 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2167 5) Same without array mask:
2168 limit = infinities_supported ? Infinity : huge (limit);
2169 pos = (from <= to) ? 1 : 0;
2172 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2175 For 3) and 5), if mask is scalar, this all goes into a conditional,
2176 setting pos = 0; in the else branch. */
2179 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2183 stmtblock_t ifblock;
2184 stmtblock_t elseblock;
2195 gfc_actual_arglist *actual;
2200 gfc_expr *arrayexpr;
2207 gfc_conv_intrinsic_funcall (se, expr);
2211 /* Initialize the result. */
2212 pos = gfc_create_var (gfc_array_index_type, "pos");
2213 offset = gfc_create_var (gfc_array_index_type, "offset");
2214 type = gfc_typenode_for_spec (&expr->ts);
2216 /* Walk the arguments. */
2217 actual = expr->value.function.actual;
2218 arrayexpr = actual->expr;
2219 arrayss = gfc_walk_expr (arrayexpr);
2220 gcc_assert (arrayss != gfc_ss_terminator);
2222 actual = actual->next->next;
2223 gcc_assert (actual);
2224 maskexpr = actual->expr;
2226 if (maskexpr && maskexpr->rank != 0)
2228 maskss = gfc_walk_expr (maskexpr);
2229 gcc_assert (maskss != gfc_ss_terminator);
2234 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2236 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2238 nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2239 gfc_index_zero_node);
2244 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2245 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2246 switch (arrayexpr->ts.type)
2249 if (HONOR_INFINITIES (DECL_MODE (limit)))
2251 REAL_VALUE_TYPE real;
2253 tmp = build_real (TREE_TYPE (limit), real);
2256 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2257 arrayexpr->ts.kind, 0);
2261 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2262 arrayexpr->ts.kind);
2269 /* We start with the most negative possible value for MAXLOC, and the most
2270 positive possible value for MINLOC. The most negative possible value is
2271 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2272 possible value is HUGE in both cases. */
2274 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2275 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2276 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2277 build_int_cst (type, 1));
2279 gfc_add_modify (&se->pre, limit, tmp);
2281 /* Initialize the scalarizer. */
2282 gfc_init_loopinfo (&loop);
2283 gfc_add_ss_to_loop (&loop, arrayss);
2285 gfc_add_ss_to_loop (&loop, maskss);
2287 /* Initialize the loop. */
2288 gfc_conv_ss_startstride (&loop);
2289 gfc_conv_loop_setup (&loop, &expr->where);
2291 gcc_assert (loop.dimen == 1);
2292 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2293 nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2298 /* Initialize the position to zero, following Fortran 2003. We are free
2299 to do this because Fortran 95 allows the result of an entirely false
2300 mask to be processor dependent. If we know at compile time the array
2301 is non-empty and no MASK is used, we can initialize to 1 to simplify
2303 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2304 gfc_add_modify (&loop.pre, pos,
2305 fold_build3 (COND_EXPR, gfc_array_index_type,
2306 nonempty, gfc_index_one_node,
2307 gfc_index_zero_node));
2310 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2311 lab1 = gfc_build_label_decl (NULL_TREE);
2312 TREE_USED (lab1) = 1;
2313 lab2 = gfc_build_label_decl (NULL_TREE);
2314 TREE_USED (lab2) = 1;
2317 gfc_mark_ss_chain_used (arrayss, 1);
2319 gfc_mark_ss_chain_used (maskss, 1);
2320 /* Generate the loop body. */
2321 gfc_start_scalarized_body (&loop, &body);
2323 /* If we have a mask, only check this element if the mask is set. */
2326 gfc_init_se (&maskse, NULL);
2327 gfc_copy_loopinfo_to_se (&maskse, &loop);
2329 gfc_conv_expr_val (&maskse, maskexpr);
2330 gfc_add_block_to_block (&body, &maskse.pre);
2332 gfc_start_block (&block);
2335 gfc_init_block (&block);
2337 /* Compare with the current limit. */
2338 gfc_init_se (&arrayse, NULL);
2339 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2340 arrayse.ss = arrayss;
2341 gfc_conv_expr_val (&arrayse, arrayexpr);
2342 gfc_add_block_to_block (&block, &arrayse.pre);
2344 /* We do the following if this is a more extreme value. */
2345 gfc_start_block (&ifblock);
2347 /* Assign the value to the limit... */
2348 gfc_add_modify (&ifblock, limit, arrayse.expr);
2350 /* Remember where we are. An offset must be added to the loop
2351 counter to obtain the required position. */
2353 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2354 gfc_index_one_node, loop.from[0]);
2356 tmp = gfc_index_one_node;
2358 gfc_add_modify (&block, offset, tmp);
2360 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2362 stmtblock_t ifblock2;
2365 gfc_start_block (&ifblock2);
2366 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2367 loop.loopvar[0], offset);
2368 gfc_add_modify (&ifblock2, pos, tmp);
2369 ifbody2 = gfc_finish_block (&ifblock2);
2370 cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
2371 gfc_index_zero_node);
2372 tmp = build3_v (COND_EXPR, cond, ifbody2,
2373 build_empty_stmt (input_location));
2374 gfc_add_expr_to_block (&block, tmp);
2377 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2378 loop.loopvar[0], offset);
2379 gfc_add_modify (&ifblock, pos, tmp);
2382 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2384 ifbody = gfc_finish_block (&ifblock);
2386 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2389 cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2390 boolean_type_node, arrayse.expr, limit);
2392 cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2394 ifbody = build3_v (COND_EXPR, cond, ifbody,
2395 build_empty_stmt (input_location));
2397 gfc_add_expr_to_block (&block, ifbody);
2401 /* We enclose the above in if (mask) {...}. */
2402 tmp = gfc_finish_block (&block);
2404 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2405 build_empty_stmt (input_location));
2408 tmp = gfc_finish_block (&block);
2409 gfc_add_expr_to_block (&body, tmp);
2413 gfc_trans_scalarized_loop_end (&loop, 0, &body);
2415 if (HONOR_NANS (DECL_MODE (limit)))
2417 if (nonempty != NULL)
2419 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2420 tmp = build3_v (COND_EXPR, nonempty, ifbody,
2421 build_empty_stmt (input_location));
2422 gfc_add_expr_to_block (&loop.code[0], tmp);
2426 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2427 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2428 gfc_start_block (&body);
2430 /* If we have a mask, only check this element if the mask is set. */
2433 gfc_init_se (&maskse, NULL);
2434 gfc_copy_loopinfo_to_se (&maskse, &loop);
2436 gfc_conv_expr_val (&maskse, maskexpr);
2437 gfc_add_block_to_block (&body, &maskse.pre);
2439 gfc_start_block (&block);
2442 gfc_init_block (&block);
2444 /* Compare with the current limit. */
2445 gfc_init_se (&arrayse, NULL);
2446 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2447 arrayse.ss = arrayss;
2448 gfc_conv_expr_val (&arrayse, arrayexpr);
2449 gfc_add_block_to_block (&block, &arrayse.pre);
2451 /* We do the following if this is a more extreme value. */
2452 gfc_start_block (&ifblock);
2454 /* Assign the value to the limit... */
2455 gfc_add_modify (&ifblock, limit, arrayse.expr);
2457 /* Remember where we are. An offset must be added to the loop
2458 counter to obtain the required position. */
2460 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2461 gfc_index_one_node, loop.from[0]);
2463 tmp = gfc_index_one_node;
2465 gfc_add_modify (&block, offset, tmp);
2467 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2468 loop.loopvar[0], offset);
2469 gfc_add_modify (&ifblock, pos, tmp);
2471 ifbody = gfc_finish_block (&ifblock);
2473 cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2475 tmp = build3_v (COND_EXPR, cond, ifbody,
2476 build_empty_stmt (input_location));
2477 gfc_add_expr_to_block (&block, tmp);
2481 /* We enclose the above in if (mask) {...}. */
2482 tmp = gfc_finish_block (&block);
2484 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2485 build_empty_stmt (input_location));
2488 tmp = gfc_finish_block (&block);
2489 gfc_add_expr_to_block (&body, tmp);
2490 /* Avoid initializing loopvar[0] again, it should be left where
2491 it finished by the first loop. */
2492 loop.from[0] = loop.loopvar[0];
2495 gfc_trans_scalarizing_loops (&loop, &body);
2498 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2500 /* For a scalar mask, enclose the loop in an if statement. */
2501 if (maskexpr && maskss == NULL)
2503 gfc_init_se (&maskse, NULL);
2504 gfc_conv_expr_val (&maskse, maskexpr);
2505 gfc_init_block (&block);
2506 gfc_add_block_to_block (&block, &loop.pre);
2507 gfc_add_block_to_block (&block, &loop.post);
2508 tmp = gfc_finish_block (&block);
2510 /* For the else part of the scalar mask, just initialize
2511 the pos variable the same way as above. */
2513 gfc_init_block (&elseblock);
2514 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2515 elsetmp = gfc_finish_block (&elseblock);
2517 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2518 gfc_add_expr_to_block (&block, tmp);
2519 gfc_add_block_to_block (&se->pre, &block);
2523 gfc_add_block_to_block (&se->pre, &loop.pre);
2524 gfc_add_block_to_block (&se->pre, &loop.post);
2526 gfc_cleanup_loop (&loop);
2528 se->expr = convert (type, pos);
2531 /* Emit code for minval or maxval intrinsic. There are many different cases
2532 we need to handle. For performance reasons we sometimes create two
2533 loops instead of one, where the second one is much simpler.
2534 Examples for minval intrinsic:
2535 1) Result is an array, a call is generated
2536 2) Array mask is used and NaNs need to be supported, rank 1:
2541 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2544 limit = nonempty ? NaN : huge (limit);
2546 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2547 3) NaNs need to be supported, but it is known at compile time or cheaply
2548 at runtime whether array is nonempty or not, rank 1:
2551 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2552 limit = (from <= to) ? NaN : huge (limit);
2554 while (S <= to) { limit = min (a[S], limit); S++; }
2555 4) Array mask is used and NaNs need to be supported, rank > 1:
2564 if (fast) limit = min (a[S1][S2], limit);
2567 if (a[S1][S2] <= limit) {
2578 limit = nonempty ? NaN : huge (limit);
2579 5) NaNs need to be supported, but it is known at compile time or cheaply
2580 at runtime whether array is nonempty or not, rank > 1:
2587 if (fast) limit = min (a[S1][S2], limit);
2589 if (a[S1][S2] <= limit) {
2599 limit = (nonempty_array) ? NaN : huge (limit);
2600 6) NaNs aren't supported, but infinities are. Array mask is used:
2605 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2608 limit = nonempty ? limit : huge (limit);
2609 7) Same without array mask:
2612 while (S <= to) { limit = min (a[S], limit); S++; }
2613 limit = (from <= to) ? limit : huge (limit);
2614 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2615 limit = huge (limit);
2617 while (S <= to) { limit = min (a[S], limit); S++); }
2619 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2620 with array mask instead).
2621 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2622 setting limit = huge (limit); in the else branch. */
2625 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2635 tree huge_cst = NULL, nan_cst = NULL;
2637 stmtblock_t block, block2;
2639 gfc_actual_arglist *actual;
2644 gfc_expr *arrayexpr;
2650 gfc_conv_intrinsic_funcall (se, expr);
2654 type = gfc_typenode_for_spec (&expr->ts);
2655 /* Initialize the result. */
2656 limit = gfc_create_var (type, "limit");
2657 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2658 switch (expr->ts.type)
2661 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2663 if (HONOR_INFINITIES (DECL_MODE (limit)))
2665 REAL_VALUE_TYPE real;
2667 tmp = build_real (type, real);
2671 if (HONOR_NANS (DECL_MODE (limit)))
2673 REAL_VALUE_TYPE real;
2674 real_nan (&real, "", 1, DECL_MODE (limit));
2675 nan_cst = build_real (type, real);
2680 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2687 /* We start with the most negative possible value for MAXVAL, and the most
2688 positive possible value for MINVAL. The most negative possible value is
2689 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2690 possible value is HUGE in both cases. */
2693 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2695 huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
2698 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2699 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2700 tmp, build_int_cst (type, 1));
2702 gfc_add_modify (&se->pre, limit, tmp);
2704 /* Walk the arguments. */
2705 actual = expr->value.function.actual;
2706 arrayexpr = actual->expr;
2707 arrayss = gfc_walk_expr (arrayexpr);
2708 gcc_assert (arrayss != gfc_ss_terminator);
2710 actual = actual->next->next;
2711 gcc_assert (actual);
2712 maskexpr = actual->expr;
2714 if (maskexpr && maskexpr->rank != 0)
2716 maskss = gfc_walk_expr (maskexpr);
2717 gcc_assert (maskss != gfc_ss_terminator);
2722 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2724 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2726 nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2727 gfc_index_zero_node);
2732 /* Initialize the scalarizer. */
2733 gfc_init_loopinfo (&loop);
2734 gfc_add_ss_to_loop (&loop, arrayss);
2736 gfc_add_ss_to_loop (&loop, maskss);
2738 /* Initialize the loop. */
2739 gfc_conv_ss_startstride (&loop);
2740 gfc_conv_loop_setup (&loop, &expr->where);
2742 if (nonempty == NULL && maskss == NULL
2743 && loop.dimen == 1 && loop.from[0] && loop.to[0])
2744 nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2746 nonempty_var = NULL;
2747 if (nonempty == NULL
2748 && (HONOR_INFINITIES (DECL_MODE (limit))
2749 || HONOR_NANS (DECL_MODE (limit))))
2751 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2752 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2753 nonempty = nonempty_var;
2757 if (HONOR_NANS (DECL_MODE (limit)))
2759 if (loop.dimen == 1)
2761 lab = gfc_build_label_decl (NULL_TREE);
2762 TREE_USED (lab) = 1;
2766 fast = gfc_create_var (boolean_type_node, "fast");
2767 gfc_add_modify (&se->pre, fast, boolean_false_node);
2771 gfc_mark_ss_chain_used (arrayss, 1);
2773 gfc_mark_ss_chain_used (maskss, 1);
2774 /* Generate the loop body. */
2775 gfc_start_scalarized_body (&loop, &body);
2777 /* If we have a mask, only add this element if the mask is set. */
2780 gfc_init_se (&maskse, NULL);
2781 gfc_copy_loopinfo_to_se (&maskse, &loop);
2783 gfc_conv_expr_val (&maskse, maskexpr);
2784 gfc_add_block_to_block (&body, &maskse.pre);
2786 gfc_start_block (&block);
2789 gfc_init_block (&block);
2791 /* Compare with the current limit. */
2792 gfc_init_se (&arrayse, NULL);
2793 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2794 arrayse.ss = arrayss;
2795 gfc_conv_expr_val (&arrayse, arrayexpr);
2796 gfc_add_block_to_block (&block, &arrayse.pre);
2798 gfc_init_block (&block2);
2801 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2803 if (HONOR_NANS (DECL_MODE (limit)))
2805 tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2806 boolean_type_node, arrayse.expr, limit);
2808 ifbody = build1_v (GOTO_EXPR, lab);
2811 stmtblock_t ifblock;
2813 gfc_init_block (&ifblock);
2814 gfc_add_modify (&ifblock, limit, arrayse.expr);
2815 gfc_add_modify (&ifblock, fast, boolean_true_node);
2816 ifbody = gfc_finish_block (&ifblock);
2818 tmp = build3_v (COND_EXPR, tmp, ifbody,
2819 build_empty_stmt (input_location));
2820 gfc_add_expr_to_block (&block2, tmp);
2824 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2826 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2828 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2829 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2830 tmp = build3_v (COND_EXPR, tmp, ifbody,
2831 build_empty_stmt (input_location));
2832 gfc_add_expr_to_block (&block2, tmp);
2836 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2837 type, arrayse.expr, limit);
2838 gfc_add_modify (&block2, limit, tmp);
2844 tree elsebody = gfc_finish_block (&block2);
2846 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2848 if (HONOR_NANS (DECL_MODE (limit))
2849 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2851 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2852 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2853 ifbody = build3_v (COND_EXPR, tmp, ifbody,
2854 build_empty_stmt (input_location));
2858 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2859 type, arrayse.expr, limit);
2860 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2862 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
2863 gfc_add_expr_to_block (&block, tmp);
2866 gfc_add_block_to_block (&block, &block2);
2868 gfc_add_block_to_block (&block, &arrayse.post);
2870 tmp = gfc_finish_block (&block);
2872 /* We enclose the above in if (mask) {...}. */
2873 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2874 build_empty_stmt (input_location));
2875 gfc_add_expr_to_block (&body, tmp);
2879 gfc_trans_scalarized_loop_end (&loop, 0, &body);
2881 tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2882 gfc_add_modify (&loop.code[0], limit, tmp);
2883 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
2885 gfc_start_block (&body);
2887 /* If we have a mask, only add this element if the mask is set. */
2890 gfc_init_se (&maskse, NULL);
2891 gfc_copy_loopinfo_to_se (&maskse, &loop);
2893 gfc_conv_expr_val (&maskse, maskexpr);
2894 gfc_add_block_to_block (&body, &maskse.pre);
2896 gfc_start_block (&block);
2899 gfc_init_block (&block);
2901 /* Compare with the current limit. */
2902 gfc_init_se (&arrayse, NULL);
2903 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2904 arrayse.ss = arrayss;
2905 gfc_conv_expr_val (&arrayse, arrayexpr);
2906 gfc_add_block_to_block (&block, &arrayse.pre);
2908 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2910 if (HONOR_NANS (DECL_MODE (limit))
2911 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2913 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2914 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2915 tmp = build3_v (COND_EXPR, tmp, ifbody,
2916 build_empty_stmt (input_location));
2917 gfc_add_expr_to_block (&block, tmp);
2921 tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2922 type, arrayse.expr, limit);
2923 gfc_add_modify (&block, limit, tmp);
2926 gfc_add_block_to_block (&block, &arrayse.post);
2928 tmp = gfc_finish_block (&block);
2930 /* We enclose the above in if (mask) {...}. */
2931 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2932 build_empty_stmt (input_location));
2933 gfc_add_expr_to_block (&body, tmp);
2934 /* Avoid initializing loopvar[0] again, it should be left where
2935 it finished by the first loop. */
2936 loop.from[0] = loop.loopvar[0];
2938 gfc_trans_scalarizing_loops (&loop, &body);
2942 tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2943 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2944 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
2946 gfc_add_expr_to_block (&loop.pre, tmp);
2948 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
2950 tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
2951 gfc_add_modify (&loop.pre, limit, tmp);
2954 /* For a scalar mask, enclose the loop in an if statement. */
2955 if (maskexpr && maskss == NULL)
2959 gfc_init_se (&maskse, NULL);
2960 gfc_conv_expr_val (&maskse, maskexpr);
2961 gfc_init_block (&block);
2962 gfc_add_block_to_block (&block, &loop.pre);
2963 gfc_add_block_to_block (&block, &loop.post);
2964 tmp = gfc_finish_block (&block);
2966 if (HONOR_INFINITIES (DECL_MODE (limit)))
2967 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
2969 else_stmt = build_empty_stmt (input_location);
2970 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
2971 gfc_add_expr_to_block (&block, tmp);
2972 gfc_add_block_to_block (&se->pre, &block);
2976 gfc_add_block_to_block (&se->pre, &loop.pre);
2977 gfc_add_block_to_block (&se->pre, &loop.post);
2980 gfc_cleanup_loop (&loop);
2985 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2987 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2993 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2994 type = TREE_TYPE (args[0]);
2996 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2997 tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2998 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2999 build_int_cst (type, 0));
3000 type = gfc_typenode_for_spec (&expr->ts);
3001 se->expr = convert (type, tmp);
3004 /* Generate code to perform the specified operation. */
3006 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3010 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3011 se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
3016 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3020 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3021 se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
3024 /* Set or clear a single bit. */
3026 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3033 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3034 type = TREE_TYPE (args[0]);
3036 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3042 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
3044 se->expr = fold_build2 (op, type, args[0], tmp);
3047 /* Extract a sequence of bits.
3048 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3050 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3057 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3058 type = TREE_TYPE (args[0]);
3060 mask = build_int_cst (type, -1);
3061 mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
3062 mask = fold_build1 (BIT_NOT_EXPR, type, mask);
3064 tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
3066 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
3069 /* RSHIFT (I, SHIFT) = I >> SHIFT
3070 LSHIFT (I, SHIFT) = I << SHIFT */
3072 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3076 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3078 se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3079 TREE_TYPE (args[0]), args[0], args[1]);
3082 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3084 : ((shift >= 0) ? i << shift : i >> -shift)
3085 where all shifts are logical shifts. */
3087 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3099 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3100 type = TREE_TYPE (args[0]);
3101 utype = unsigned_type_for (type);
3103 width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
3105 /* Left shift if positive. */
3106 lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
3108 /* Right shift if negative.
3109 We convert to an unsigned type because we want a logical shift.
3110 The standard doesn't define the case of shifting negative
3111 numbers, and we try to be compatible with other compilers, most
3112 notably g77, here. */
3113 rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
3114 convert (utype, args[0]), width));
3116 tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
3117 build_int_cst (TREE_TYPE (args[1]), 0));
3118 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
3120 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3121 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3123 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3124 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
3126 se->expr = fold_build3 (COND_EXPR, type, cond,
3127 build_int_cst (type, 0), tmp);
3131 /* Circular shift. AKA rotate or barrel shift. */
3134 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3142 unsigned int num_args;
3144 num_args = gfc_intrinsic_argument_list_length (expr);
3145 args = (tree *) alloca (sizeof (tree) * num_args);
3147 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3151 /* Use a library function for the 3 parameter version. */
3152 tree int4type = gfc_get_int_type (4);
3154 type = TREE_TYPE (args[0]);
3155 /* We convert the first argument to at least 4 bytes, and
3156 convert back afterwards. This removes the need for library
3157 functions for all argument sizes, and function will be
3158 aligned to at least 32 bits, so there's no loss. */
3159 if (expr->ts.kind < 4)
3160 args[0] = convert (int4type, args[0]);
3162 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3163 need loads of library functions. They cannot have values >
3164 BIT_SIZE (I) so the conversion is safe. */
3165 args[1] = convert (int4type, args[1]);
3166 args[2] = convert (int4type, args[2]);
3168 switch (expr->ts.kind)
3173 tmp = gfor_fndecl_math_ishftc4;
3176 tmp = gfor_fndecl_math_ishftc8;
3179 tmp = gfor_fndecl_math_ishftc16;
3184 se->expr = build_call_expr_loc (input_location,
3185 tmp, 3, args[0], args[1], args[2]);
3186 /* Convert the result back to the original type, if we extended
3187 the first argument's width above. */
3188 if (expr->ts.kind < 4)
3189 se->expr = convert (type, se->expr);
3193 type = TREE_TYPE (args[0]);
3195 /* Rotate left if positive. */
3196 lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
3198 /* Rotate right if negative. */
3199 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
3200 rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
3202 zero = build_int_cst (TREE_TYPE (args[1]), 0);
3203 tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
3204 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
3206 /* Do nothing if shift == 0. */
3207 tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
3208 se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
3211 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3212 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3214 The conditional expression is necessary because the result of LEADZ(0)
3215 is defined, but the result of __builtin_clz(0) is undefined for most
3218 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3219 difference in bit size between the argument of LEADZ and the C int. */
3222 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3234 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3235 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3237 /* Which variant of __builtin_clz* should we call? */
3238 if (argsize <= INT_TYPE_SIZE)
3240 arg_type = unsigned_type_node;
3241 func = built_in_decls[BUILT_IN_CLZ];
3243 else if (argsize <= LONG_TYPE_SIZE)
3245 arg_type = long_unsigned_type_node;
3246 func = built_in_decls[BUILT_IN_CLZL];
3248 else if (argsize <= LONG_LONG_TYPE_SIZE)
3250 arg_type = long_long_unsigned_type_node;
3251 func = built_in_decls[BUILT_IN_CLZLL];
3255 gcc_assert (argsize == 128);
3256 arg_type = gfc_build_uint_type (argsize);
3257 func = gfor_fndecl_clz128;
3260 /* Convert the actual argument twice: first, to the unsigned type of the
3261 same size; then, to the proper argument type for the built-in
3262 function. But the return type is of the default INTEGER kind. */
3263 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3264 arg = fold_convert (arg_type, arg);
3265 result_type = gfc_get_int_type (gfc_default_integer_kind);
3267 /* Compute LEADZ for the case i .ne. 0. */
3268 s = TYPE_PRECISION (arg_type) - argsize;
3269 tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
3270 leadz = fold_build2 (MINUS_EXPR, result_type,
3271 tmp, build_int_cst (result_type, s));
3273 /* Build BIT_SIZE. */
3274 bit_size = build_int_cst (result_type, argsize);
3276 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3277 arg, build_int_cst (arg_type, 0));
3278 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
3281 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3283 The conditional expression is necessary because the result of TRAILZ(0)
3284 is defined, but the result of __builtin_ctz(0) is undefined for most
3288 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3299 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3300 argsize = TYPE_PRECISION (TREE_TYPE (arg));
3302 /* Which variant of __builtin_ctz* should we call? */
3303 if (argsize <= INT_TYPE_SIZE)
3305 arg_type = unsigned_type_node;
3306 func = built_in_decls[BUILT_IN_CTZ];
3308 else if (argsize <= LONG_TYPE_SIZE)
3310 arg_type = long_unsigned_type_node;
3311 func = built_in_decls[BUILT_IN_CTZL];
3313 else if (argsize <= LONG_LONG_TYPE_SIZE)
3315 arg_type = long_long_unsigned_type_node;
3316 func = built_in_decls[BUILT_IN_CTZLL];
3320 gcc_assert (argsize == 128);
3321 arg_type = gfc_build_uint_type (argsize);
3322 func = gfor_fndecl_ctz128;
3325 /* Convert the actual argument twice: first, to the unsigned type of the
3326 same size; then, to the proper argument type for the built-in
3327 function. But the return type is of the default INTEGER kind. */
3328 arg = fold_convert (gfc_build_uint_type (argsize), arg);
3329 arg = fold_convert (arg_type, arg);
3330 result_type = gfc_get_int_type (gfc_default_integer_kind);
3332 /* Compute TRAILZ for the case i .ne. 0. */
3333 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3336 /* Build BIT_SIZE. */
3337 bit_size = build_int_cst (result_type, argsize);
3339 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3340 arg, build_int_cst (arg_type, 0));
3341 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
3344 /* Process an intrinsic with unspecified argument-types that has an optional
3345 argument (which could be of type character), e.g. EOSHIFT. For those, we
3346 need to append the string length of the optional argument if it is not
3347 present and the type is really character.
3348 primary specifies the position (starting at 1) of the non-optional argument
3349 specifying the type and optional gives the position of the optional
3350 argument in the arglist. */
3353 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3354 unsigned primary, unsigned optional)
3356 gfc_actual_arglist* prim_arg;
3357 gfc_actual_arglist* opt_arg;
3359 gfc_actual_arglist* arg;
3363 /* Find the two arguments given as position. */
3367 for (arg = expr->value.function.actual; arg; arg = arg->next)
3371 if (cur_pos == primary)
3373 if (cur_pos == optional)
3376 if (cur_pos >= primary && cur_pos >= optional)
3379 gcc_assert (prim_arg);
3380 gcc_assert (prim_arg->expr);
3381 gcc_assert (opt_arg);
3383 /* If we do have type CHARACTER and the optional argument is really absent,
3384 append a dummy 0 as string length. */
3385 append_args = NULL_TREE;
3386 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3390 dummy = build_int_cst (gfc_charlen_type_node, 0);
3391 append_args = gfc_chainon_list (append_args, dummy);
3394 /* Build the call itself. */
3395 sym = gfc_get_symbol_for_expr (expr);
3396 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3402 /* The length of a character string. */
3404 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3414 gcc_assert (!se->ss);
3416 arg = expr->value.function.actual->expr;
3418 type = gfc_typenode_for_spec (&expr->ts);
3419 switch (arg->expr_type)
3422 len = build_int_cst (NULL_TREE, arg->value.character.length);
3426 /* Obtain the string length from the function used by
3427 trans-array.c(gfc_trans_array_constructor). */
3429 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3433 if (arg->ref == NULL
3434 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3436 /* This doesn't catch all cases.
3437 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3438 and the surrounding thread. */
3439 sym = arg->symtree->n.sym;
3440 decl = gfc_get_symbol_decl (sym);
3441 if (decl == current_function_decl && sym->attr.function
3442 && (sym->result == sym))
3443 decl = gfc_get_fake_result_decl (sym, 0);
3445 len = sym->ts.u.cl->backend_decl;
3450 /* Otherwise fall through. */
3453 /* Anybody stupid enough to do this deserves inefficient code. */
3454 ss = gfc_walk_expr (arg);
3455 gfc_init_se (&argse, se);
3456 if (ss == gfc_ss_terminator)
3457 gfc_conv_expr (&argse, arg);
3459 gfc_conv_expr_descriptor (&argse, arg, ss);
3460 gfc_add_block_to_block (&se->pre, &argse.pre);
3461 gfc_add_block_to_block (&se->post, &argse.post);
3462 len = argse.string_length;
3465 se->expr = convert (type, len);
3468 /* The length of a character string not including trailing blanks. */
3470 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3472 int kind = expr->value.function.actual->expr->ts.kind;
3473 tree args[2], type, fndecl;
3475 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3476 type = gfc_typenode_for_spec (&expr->ts);
3479 fndecl = gfor_fndecl_string_len_trim;
3481 fndecl = gfor_fndecl_string_len_trim_char4;
3485 se->expr = build_call_expr_loc (input_location,
3486 fndecl, 2, args[0], args[1]);
3487 se->expr = convert (type, se->expr);
3491 /* Returns the starting position of a substring within a string. */
3494 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3497 tree logical4_type_node = gfc_get_logical_type (4);
3501 unsigned int num_args;
3503 args = (tree *) alloca (sizeof (tree) * 5);
3505 /* Get number of arguments; characters count double due to the
3506 string length argument. Kind= is not passed to the library
3507 and thus ignored. */
3508 if (expr->value.function.actual->next->next->expr == NULL)
3513 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3514 type = gfc_typenode_for_spec (&expr->ts);
3517 args[4] = build_int_cst (logical4_type_node, 0);
3519 args[4] = convert (logical4_type_node, args[4]);
3521 fndecl = build_addr (function, current_function_decl);
3522 se->expr = build_call_array_loc (input_location,
3523 TREE_TYPE (TREE_TYPE (function)), fndecl,
3525 se->expr = convert (type, se->expr);
3529 /* The ascii value for a single character. */
3531 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3533 tree args[2], type, pchartype;
3535 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3536 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3537 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3538 args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3539 type = gfc_typenode_for_spec (&expr->ts);
3541 se->expr = build_fold_indirect_ref_loc (input_location,
3543 se->expr = convert (type, se->expr);
3547 /* Intrinsic ISNAN calls __builtin_isnan. */
3550 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3554 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3555 se->expr = build_call_expr_loc (input_location,
3556 built_in_decls[BUILT_IN_ISNAN], 1, arg);
3557 STRIP_TYPE_NOPS (se->expr);
3558 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3562 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3563 their argument against a constant integer value. */
3566 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3570 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3571 se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3572 arg, build_int_cst (TREE_TYPE (arg), value));
3577 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3580 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3588 unsigned int num_args;
3590 num_args = gfc_intrinsic_argument_list_length (expr);
3591 args = (tree *) alloca (sizeof (tree) * num_args);
3593 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3594 if (expr->ts.type != BT_CHARACTER)
3602 /* We do the same as in the non-character case, but the argument
3603 list is different because of the string length arguments. We
3604 also have to set the string length for the result. */
3611 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3613 se->string_length = len;
3615 type = TREE_TYPE (tsource);
3616 se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3617 fold_convert (type, fsource));
3621 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3623 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3625 tree arg, type, tmp;
3628 switch (expr->ts.kind)
3631 frexp = BUILT_IN_FREXPF;
3634 frexp = BUILT_IN_FREXP;
3638 frexp = BUILT_IN_FREXPL;
3644 type = gfc_typenode_for_spec (&expr->ts);
3645 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3646 tmp = gfc_create_var (integer_type_node, NULL);
3647 se->expr = build_call_expr_loc (input_location,
3648 built_in_decls[frexp], 2,
3649 fold_convert (type, arg),
3650 gfc_build_addr_expr (NULL_TREE, tmp));
3651 se->expr = fold_convert (type, se->expr);
3655 /* NEAREST (s, dir) is translated into
3656 tmp = copysign (HUGE_VAL, dir);
3657 return nextafter (s, tmp);
3660 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3662 tree args[2], type, tmp;
3663 int nextafter, copysign, huge_val;
3665 switch (expr->ts.kind)
3668 nextafter = BUILT_IN_NEXTAFTERF;
3669 copysign = BUILT_IN_COPYSIGNF;
3670 huge_val = BUILT_IN_HUGE_VALF;
3673 nextafter = BUILT_IN_NEXTAFTER;
3674 copysign = BUILT_IN_COPYSIGN;
3675 huge_val = BUILT_IN_HUGE_VAL;
3679 nextafter = BUILT_IN_NEXTAFTERL;
3680 copysign = BUILT_IN_COPYSIGNL;
3681 huge_val = BUILT_IN_HUGE_VALL;
3687 type = gfc_typenode_for_spec (&expr->ts);
3688 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3689 tmp = build_call_expr_loc (input_location,
3690 built_in_decls[copysign], 2,
3691 build_call_expr_loc (input_location,
3692 built_in_decls[huge_val], 0),
3693 fold_convert (type, args[1]));
3694 se->expr = build_call_expr_loc (input_location,
3695 built_in_decls[nextafter], 2,
3696 fold_convert (type, args[0]), tmp);
3697 se->expr = fold_convert (type, se->expr);
3701 /* SPACING (s) is translated into
3709 e = MAX_EXPR (e, emin);
3710 res = scalbn (1., e);
3714 where prec is the precision of s, gfc_real_kinds[k].digits,
3715 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3716 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3719 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3721 tree arg, type, prec, emin, tiny, res, e;
3723 int frexp, scalbn, k;
3726 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3727 prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3728 emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3729 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3731 switch (expr->ts.kind)
3734 frexp = BUILT_IN_FREXPF;
3735 scalbn = BUILT_IN_SCALBNF;
3738 frexp = BUILT_IN_FREXP;
3739 scalbn = BUILT_IN_SCALBN;
3743 frexp = BUILT_IN_FREXPL;
3744 scalbn = BUILT_IN_SCALBNL;
3750 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3751 arg = gfc_evaluate_now (arg, &se->pre);
3753 type = gfc_typenode_for_spec (&expr->ts);
3754 e = gfc_create_var (integer_type_node, NULL);
3755 res = gfc_create_var (type, NULL);
3758 /* Build the block for s /= 0. */
3759 gfc_start_block (&block);
3760 tmp = build_call_expr_loc (input_location,
3761 built_in_decls[frexp], 2, arg,
3762 gfc_build_addr_expr (NULL_TREE, e));
3763 gfc_add_expr_to_block (&block, tmp);
3765 tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3766 gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3769 tmp = build_call_expr_loc (input_location,
3770 built_in_decls[scalbn], 2,
3771 build_real_from_int_cst (type, integer_one_node), e);
3772 gfc_add_modify (&block, res, tmp);
3774 /* Finish by building the IF statement. */
3775 cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3776 build_real_from_int_cst (type, integer_zero_node));
3777 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3778 gfc_finish_block (&block));
3780 gfc_add_expr_to_block (&se->pre, tmp);
3785 /* RRSPACING (s) is translated into
3792 x = scalbn (x, precision - e);
3796 where precision is gfc_real_kinds[k].digits. */
3799 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3801 tree arg, type, e, x, cond, stmt, tmp;
3802 int frexp, scalbn, fabs, prec, k;
3805 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3806 prec = gfc_real_kinds[k].digits;
3807 switch (expr->ts.kind)
3810 frexp = BUILT_IN_FREXPF;
3811 scalbn = BUILT_IN_SCALBNF;
3812 fabs = BUILT_IN_FABSF;
3815 frexp = BUILT_IN_FREXP;
3816 scalbn = BUILT_IN_SCALBN;
3817 fabs = BUILT_IN_FABS;
3821 frexp = BUILT_IN_FREXPL;
3822 scalbn = BUILT_IN_SCALBNL;
3823 fabs = BUILT_IN_FABSL;
3829 type = gfc_typenode_for_spec (&expr->ts);
3830 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3831 arg = gfc_evaluate_now (arg, &se->pre);
3833 e = gfc_create_var (integer_type_node, NULL);
3834 x = gfc_create_var (type, NULL);
3835 gfc_add_modify (&se->pre, x,
3836 build_call_expr_loc (input_location,
3837 built_in_decls[fabs], 1, arg));
3840 gfc_start_block (&block);
3841 tmp = build_call_expr_loc (input_location,
3842 built_in_decls[frexp], 2, arg,
3843 gfc_build_addr_expr (NULL_TREE, e));
3844 gfc_add_expr_to_block (&block, tmp);
3846 tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3847 build_int_cst (NULL_TREE, prec), e);
3848 tmp = build_call_expr_loc (input_location,
3849 built_in_decls[scalbn], 2, x, tmp);
3850 gfc_add_modify (&block, x, tmp);
3851 stmt = gfc_finish_block (&block);
3853 cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3854 build_real_from_int_cst (type, integer_zero_node));
3855 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
3856 gfc_add_expr_to_block (&se->pre, tmp);
3858 se->expr = fold_convert (type, x);
3862 /* SCALE (s, i) is translated into scalbn (s, i). */
3864 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3869 switch (expr->ts.kind)
3872 scalbn = BUILT_IN_SCALBNF;
3875 scalbn = BUILT_IN_SCALBN;
3879 scalbn = BUILT_IN_SCALBNL;
3885 type = gfc_typenode_for_spec (&expr->ts);
3886 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3887 se->expr = build_call_expr_loc (input_location,
3888 built_in_decls[scalbn], 2,
3889 fold_convert (type, args[0]),
3890 fold_convert (integer_type_node, args[1]));
3891 se->expr = fold_convert (type, se->expr);
3895 /* SET_EXPONENT (s, i) is translated into
3896 scalbn (frexp (s, &dummy_int), i). */
3898 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3900 tree args[2], type, tmp;
3903 switch (expr->ts.kind)
3906 frexp = BUILT_IN_FREXPF;
3907 scalbn = BUILT_IN_SCALBNF;
3910 frexp = BUILT_IN_FREXP;
3911 scalbn = BUILT_IN_SCALBN;
3915 frexp = BUILT_IN_FREXPL;
3916 scalbn = BUILT_IN_SCALBNL;
3922 type = gfc_typenode_for_spec (&expr->ts);
3923 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3925 tmp = gfc_create_var (integer_type_node, NULL);
3926 tmp = build_call_expr_loc (input_location,
3927 built_in_decls[frexp], 2,
3928 fold_convert (type, args[0]),
3929 gfc_build_addr_expr (NULL_TREE, tmp));
3930 se->expr = build_call_expr_loc (input_location,
3931 built_in_decls[scalbn], 2, tmp,
3932 fold_convert (integer_type_node, args[1]));
3933 se->expr = fold_convert (type, se->expr);
3938 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3940 gfc_actual_arglist *actual;
3948 gfc_init_se (&argse, NULL);
3949 actual = expr->value.function.actual;
3951 ss = gfc_walk_expr (actual->expr);
3952 gcc_assert (ss != gfc_ss_terminator);
3953 argse.want_pointer = 1;
3954 argse.data_not_needed = 1;
3955 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3956 gfc_add_block_to_block (&se->pre, &argse.pre);
3957 gfc_add_block_to_block (&se->post, &argse.post);
3958 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3960 /* Build the call to size0. */
3961 fncall0 = build_call_expr_loc (input_location,
3962 gfor_fndecl_size0, 1, arg1);
3964 actual = actual->next;
3968 gfc_init_se (&argse, NULL);
3969 gfc_conv_expr_type (&argse, actual->expr,
3970 gfc_array_index_type);
3971 gfc_add_block_to_block (&se->pre, &argse.pre);
3973 /* Unusually, for an intrinsic, size does not exclude
3974 an optional arg2, so we must test for it. */
3975 if (actual->expr->expr_type == EXPR_VARIABLE
3976 && actual->expr->symtree->n.sym->attr.dummy
3977 && actual->expr->symtree->n.sym->attr.optional)
3980 /* Build the call to size1. */
3981 fncall1 = build_call_expr_loc (input_location,
3982 gfor_fndecl_size1, 2,
3985 gfc_init_se (&argse, NULL);
3986 argse.want_pointer = 1;
3987 argse.data_not_needed = 1;
3988 gfc_conv_expr (&argse, actual->expr);
3989 gfc_add_block_to_block (&se->pre, &argse.pre);
3990 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3991 argse.expr, null_pointer_node);
3992 tmp = gfc_evaluate_now (tmp, &se->pre);
3993 se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3994 tmp, fncall1, fncall0);
3998 se->expr = NULL_TREE;
3999 argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4000 argse.expr, gfc_index_one_node);
4003 else if (expr->value.function.actual->expr->rank == 1)
4005 argse.expr = gfc_index_zero_node;
4006 se->expr = NULL_TREE;
4011 if (se->expr == NULL_TREE)
4013 tree ubound, lbound;
4015 arg1 = build_fold_indirect_ref_loc (input_location,
4017 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
4018 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
4019 se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4021 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
4022 gfc_index_one_node);
4023 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
4024 gfc_index_zero_node);
4027 type = gfc_typenode_for_spec (&expr->ts);
4028 se->expr = convert (type, se->expr);
4032 /* Helper function to compute the size of a character variable,
4033 excluding the terminating null characters. The result has
4034 gfc_array_index_type type. */
4037 size_of_string_in_bytes (int kind, tree string_length)
4040 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
4042 bytesize = build_int_cst (gfc_array_index_type,
4043 gfc_character_kinds[i].bit_size / 8);
4045 return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
4046 fold_convert (gfc_array_index_type, string_length));
4051 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
4063 arg = expr->value.function.actual->expr;
4065 gfc_init_se (&argse, NULL);
4066 ss = gfc_walk_expr (arg);
4068 if (ss == gfc_ss_terminator)
4070 gfc_conv_expr_reference (&argse, arg);
4072 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4075 /* Obtain the source word length. */
4076 if (arg->ts.type == BT_CHARACTER)
4077 se->expr = size_of_string_in_bytes (arg->ts.kind,
4078 argse.string_length);
4080 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
4084 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
4085 argse.want_pointer = 0;
4086 gfc_conv_expr_descriptor (&argse, arg, ss);
4087 type = gfc_get_element_type (TREE_TYPE (argse.expr));
4089 /* Obtain the argument's word length. */
4090 if (arg->ts.type == BT_CHARACTER)
4091 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4093 tmp = fold_convert (gfc_array_index_type,
4094 size_in_bytes (type));
4095 gfc_add_modify (&argse.pre, source_bytes, tmp);
4097 /* Obtain the size of the array in bytes. */
4098 for (n = 0; n < arg->rank; n++)
4101 idx = gfc_rank_cst[n];
4102 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4103 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4104 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4106 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4107 tmp, gfc_index_one_node);
4108 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4110 gfc_add_modify (&argse.pre, source_bytes, tmp);
4112 se->expr = source_bytes;
4115 gfc_add_block_to_block (&se->pre, &argse.pre);
4119 /* Intrinsic string comparison functions. */
4122 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
4126 gfc_conv_intrinsic_function_args (se, expr, args, 4);
4129 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
4130 expr->value.function.actual->expr->ts.kind);
4131 se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
4132 build_int_cst (TREE_TYPE (se->expr), 0));
4135 /* Generate a call to the adjustl/adjustr library function. */
4137 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
4145 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
4148 type = TREE_TYPE (args[2]);
4149 var = gfc_conv_string_tmp (se, type, len);
4152 tmp = build_call_expr_loc (input_location,
4153 fndecl, 3, args[0], args[1], args[2]);
4154 gfc_add_expr_to_block (&se->pre, tmp);
4156 se->string_length = len;
4160 /* Generate code for the TRANSFER intrinsic:
4162 DEST = TRANSFER (SOURCE, MOLD)
4164 typeof<DEST> = typeof<MOLD>
4169 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4171 typeof<DEST> = typeof<MOLD>
4173 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4174 sizeof (DEST(0) * SIZE). */
4176 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
4192 gfc_actual_arglist *arg;
4202 info = &se->ss->data.info;
4204 /* Convert SOURCE. The output from this stage is:-
4205 source_bytes = length of the source in bytes
4206 source = pointer to the source data. */
4207 arg = expr->value.function.actual;
4209 /* Ensure double transfer through LOGICAL preserves all
4211 if (arg->expr->expr_type == EXPR_FUNCTION
4212 && arg->expr->value.function.esym == NULL
4213 && arg->expr->value.function.isym != NULL
4214 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4215 && arg->expr->ts.type == BT_LOGICAL
4216 && expr->ts.type != arg->expr->ts.type)
4217 arg->expr->value.function.name = "__transfer_in_transfer";
4219 gfc_init_se (&argse, NULL);
4220 ss = gfc_walk_expr (arg->expr);
4222 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4224 /* Obtain the pointer to source and the length of source in bytes. */
4225 if (ss == gfc_ss_terminator)
4227 gfc_conv_expr_reference (&argse, arg->expr);
4228 source = argse.expr;
4230 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4233 /* Obtain the source word length. */
4234 if (arg->expr->ts.type == BT_CHARACTER)
4235 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4236 argse.string_length);
4238 tmp = fold_convert (gfc_array_index_type,
4239 size_in_bytes (source_type));
4243 argse.want_pointer = 0;
4244 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4245 source = gfc_conv_descriptor_data_get (argse.expr);
4246 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4248 /* Repack the source if not a full variable array. */
4249 if (arg->expr->expr_type == EXPR_VARIABLE
4250 && arg->expr->ref->u.ar.type != AR_FULL)
4252 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4254 if (gfc_option.warn_array_temp)
4255 gfc_warning ("Creating array temporary at %L", &expr->where);
4257 source = build_call_expr_loc (input_location,
4258 gfor_fndecl_in_pack, 1, tmp);
4259 source = gfc_evaluate_now (source, &argse.pre);
4261 /* Free the temporary. */
4262 gfc_start_block (&block);
4263 tmp = gfc_call_free (convert (pvoid_type_node, source));
4264 gfc_add_expr_to_block (&block, tmp);
4265 stmt = gfc_finish_block (&block);
4267 /* Clean up if it was repacked. */
4268 gfc_init_block (&block);
4269 tmp = gfc_conv_array_data (argse.expr);
4270 tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
4271 tmp = build3_v (COND_EXPR, tmp, stmt,
4272 build_empty_stmt (input_location));
4273 gfc_add_expr_to_block (&block, tmp);
4274 gfc_add_block_to_block (&block, &se->post);
4275 gfc_init_block (&se->post);
4276 gfc_add_block_to_block (&se->post, &block);
4279 /* Obtain the source word length. */
4280 if (arg->expr->ts.type == BT_CHARACTER)
4281 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4282 argse.string_length);
4284 tmp = fold_convert (gfc_array_index_type,
4285 size_in_bytes (source_type));
4287 /* Obtain the size of the array in bytes. */
4288 extent = gfc_create_var (gfc_array_index_type, NULL);
4289 for (n = 0; n < arg->expr->rank; n++)
4292 idx = gfc_rank_cst[n];
4293 gfc_add_modify (&argse.pre, source_bytes, tmp);
4294 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4295 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4296 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4298 gfc_add_modify (&argse.pre, extent, tmp);
4299 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4300 extent, gfc_index_one_node);
4301 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4306 gfc_add_modify (&argse.pre, source_bytes, tmp);
4307 gfc_add_block_to_block (&se->pre, &argse.pre);
4308 gfc_add_block_to_block (&se->post, &argse.post);
4310 /* Now convert MOLD. The outputs are:
4311 mold_type = the TREE type of MOLD
4312 dest_word_len = destination word length in bytes. */
4315 gfc_init_se (&argse, NULL);
4316 ss = gfc_walk_expr (arg->expr);
4318 scalar_mold = arg->expr->rank == 0;
4320 if (ss == gfc_ss_terminator)
4322 gfc_conv_expr_reference (&argse, arg->expr);
4323 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4328 gfc_init_se (&argse, NULL);
4329 argse.want_pointer = 0;
4330 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4331 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4334 gfc_add_block_to_block (&se->pre, &argse.pre);
4335 gfc_add_block_to_block (&se->post, &argse.post);
4337 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4339 /* If this TRANSFER is nested in another TRANSFER, use a type
4340 that preserves all bits. */
4341 if (arg->expr->ts.type == BT_LOGICAL)
4342 mold_type = gfc_get_int_type (arg->expr->ts.kind);
4345 if (arg->expr->ts.type == BT_CHARACTER)
4347 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4348 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4351 tmp = fold_convert (gfc_array_index_type,
4352 size_in_bytes (mold_type));
4354 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4355 gfc_add_modify (&se->pre, dest_word_len, tmp);
4357 /* Finally convert SIZE, if it is present. */
4359 size_words = gfc_create_var (gfc_array_index_type, NULL);
4363 gfc_init_se (&argse, NULL);
4364 gfc_conv_expr_reference (&argse, arg->expr);
4365 tmp = convert (gfc_array_index_type,
4366 build_fold_indirect_ref_loc (input_location,
4368 gfc_add_block_to_block (&se->pre, &argse.pre);
4369 gfc_add_block_to_block (&se->post, &argse.post);
4374 /* Separate array and scalar results. */
4375 if (scalar_mold && tmp == NULL_TREE)
4376 goto scalar_transfer;
4378 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4379 if (tmp != NULL_TREE)
4380 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4381 tmp, dest_word_len);
4385 gfc_add_modify (&se->pre, size_bytes, tmp);
4386 gfc_add_modify (&se->pre, size_words,
4387 fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
4388 size_bytes, dest_word_len));
4390 /* Evaluate the bounds of the result. If the loop range exists, we have
4391 to check if it is too large. If so, we modify loop->to be consistent
4392 with min(size, size(source)). Otherwise, size is made consistent with
4393 the loop range, so that the right number of bytes is transferred.*/
4394 n = se->loop->order[0];
4395 if (se->loop->to[n] != NULL_TREE)
4397 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4398 se->loop->to[n], se->loop->from[n]);
4399 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4400 tmp, gfc_index_one_node);
4401 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
4403 gfc_add_modify (&se->pre, size_words, tmp);
4404 gfc_add_modify (&se->pre, size_bytes,
4405 fold_build2 (MULT_EXPR, gfc_array_index_type,
4406 size_words, dest_word_len));
4407 upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4408 size_words, se->loop->from[n]);
4409 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4410 upper, gfc_index_one_node);
4414 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4415 size_words, gfc_index_one_node);
4416 se->loop->from[n] = gfc_index_zero_node;
4419 se->loop->to[n] = upper;
4421 /* Build a destination descriptor, using the pointer, source, as the
4423 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4424 info, mold_type, NULL_TREE, false, true, false,
4427 /* Cast the pointer to the result. */
4428 tmp = gfc_conv_descriptor_data_get (info->descriptor);
4429 tmp = fold_convert (pvoid_type_node, tmp);
4431 /* Use memcpy to do the transfer. */
4432 tmp = build_call_expr_loc (input_location,
4433 built_in_decls[BUILT_IN_MEMCPY],
4436 fold_convert (pvoid_type_node, source),
4437 fold_build2 (MIN_EXPR, gfc_array_index_type,
4438 size_bytes, source_bytes));
4439 gfc_add_expr_to_block (&se->pre, tmp);
4441 se->expr = info->descriptor;
4442 if (expr->ts.type == BT_CHARACTER)
4443 se->string_length = dest_word_len;
4447 /* Deal with scalar results. */
4449 extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
4450 dest_word_len, source_bytes);
4451 extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
4452 extent, gfc_index_zero_node);
4454 if (expr->ts.type == BT_CHARACTER)
4459 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4460 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4463 /* If source is longer than the destination, use a pointer to
4464 the source directly. */
4465 gfc_init_block (&block);
4466 gfc_add_modify (&block, tmpdecl, ptr);
4467 direct = gfc_finish_block (&block);
4469 /* Otherwise, allocate a string with the length of the destination
4470 and copy the source into it. */
4471 gfc_init_block (&block);
4472 tmp = gfc_get_pchar_type (expr->ts.kind);
4473 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4474 gfc_add_modify (&block, tmpdecl,
4475 fold_convert (TREE_TYPE (ptr), tmp));
4476 tmp = build_call_expr_loc (input_location,
4477 built_in_decls[BUILT_IN_MEMCPY], 3,
4478 fold_convert (pvoid_type_node, tmpdecl),
4479 fold_convert (pvoid_type_node, ptr),
4481 gfc_add_expr_to_block (&block, tmp);
4482 indirect = gfc_finish_block (&block);
4484 /* Wrap it up with the condition. */
4485 tmp = fold_build2 (LE_EXPR, boolean_type_node,
4486 dest_word_len, source_bytes);
4487 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4488 gfc_add_expr_to_block (&se->pre, tmp);
4491 se->string_length = dest_word_len;
4495 tmpdecl = gfc_create_var (mold_type, "transfer");
4497 ptr = convert (build_pointer_type (mold_type), source);
4499 /* Use memcpy to do the transfer. */
4500 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4501 tmp = build_call_expr_loc (input_location,
4502 built_in_decls[BUILT_IN_MEMCPY], 3,
4503 fold_convert (pvoid_type_node, tmp),
4504 fold_convert (pvoid_type_node, ptr),
4506 gfc_add_expr_to_block (&se->pre, tmp);
4513 /* Generate code for the ALLOCATED intrinsic.
4514 Generate inline code that directly check the address of the argument. */
4517 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4519 gfc_actual_arglist *arg1;
4524 gfc_init_se (&arg1se, NULL);
4525 arg1 = expr->value.function.actual;
4526 ss1 = gfc_walk_expr (arg1->expr);
4528 if (ss1 == gfc_ss_terminator)
4530 /* Allocatable scalar. */
4531 arg1se.want_pointer = 1;
4532 if (arg1->expr->ts.type == BT_CLASS)
4533 gfc_add_component_ref (arg1->expr, "$data");
4534 gfc_conv_expr (&arg1se, arg1->expr);
4539 /* Allocatable array. */
4540 arg1se.descriptor_only = 1;
4541 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4542 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4545 tmp = fold_build2 (NE_EXPR, boolean_type_node,
4546 tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4547 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4551 /* Generate code for the ASSOCIATED intrinsic.
4552 If both POINTER and TARGET are arrays, generate a call to library function
4553 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4554 In other cases, generate inline code that directly compare the address of
4555 POINTER with the address of TARGET. */
4558 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4560 gfc_actual_arglist *arg1;
4561 gfc_actual_arglist *arg2;
4566 tree nonzero_charlen;
4567 tree nonzero_arraylen;
4570 gfc_init_se (&arg1se, NULL);
4571 gfc_init_se (&arg2se, NULL);
4572 arg1 = expr->value.function.actual;
4573 if (arg1->expr->ts.type == BT_CLASS)
4574 gfc_add_component_ref (arg1->expr, "$data");
4576 ss1 = gfc_walk_expr (arg1->expr);
4580 /* No optional target. */
4581 if (ss1 == gfc_ss_terminator)
4583 /* A pointer to a scalar. */
4584 arg1se.want_pointer = 1;
4585 gfc_conv_expr (&arg1se, arg1->expr);
4590 /* A pointer to an array. */
4591 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4592 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4594 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4595 gfc_add_block_to_block (&se->post, &arg1se.post);
4596 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4597 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4602 /* An optional target. */
4603 ss2 = gfc_walk_expr (arg2->expr);
4605 nonzero_charlen = NULL_TREE;
4606 if (arg1->expr->ts.type == BT_CHARACTER)
4607 nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4608 arg1->expr->ts.u.cl->backend_decl,
4611 if (ss1 == gfc_ss_terminator)
4613 /* A pointer to a scalar. */
4614 gcc_assert (ss2 == gfc_ss_terminator);
4615 arg1se.want_pointer = 1;
4616 gfc_conv_expr (&arg1se, arg1->expr);
4617 arg2se.want_pointer = 1;
4618 gfc_conv_expr (&arg2se, arg2->expr);
4619 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4620 gfc_add_block_to_block (&se->post, &arg1se.post);
4621 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4622 arg1se.expr, arg2se.expr);
4623 tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4624 arg1se.expr, null_pointer_node);
4625 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4630 /* An array pointer of zero length is not associated if target is
4632 arg1se.descriptor_only = 1;
4633 gfc_conv_expr_lhs (&arg1se, arg1->expr);
4634 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4635 gfc_rank_cst[arg1->expr->rank - 1]);
4636 nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4637 build_int_cst (TREE_TYPE (tmp), 0));
4639 /* A pointer to an array, call library function _gfor_associated. */
4640 gcc_assert (ss2 != gfc_ss_terminator);
4641 arg1se.want_pointer = 1;
4642 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4644 arg2se.want_pointer = 1;
4645 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4646 gfc_add_block_to_block (&se->pre, &arg2se.pre);
4647 gfc_add_block_to_block (&se->post, &arg2se.post);
4648 se->expr = build_call_expr_loc (input_location,
4649 gfor_fndecl_associated, 2,
4650 arg1se.expr, arg2se.expr);
4651 se->expr = convert (boolean_type_node, se->expr);
4652 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4653 se->expr, nonzero_arraylen);
4656 /* If target is present zero character length pointers cannot
4658 if (nonzero_charlen != NULL_TREE)
4659 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4660 se->expr, nonzero_charlen);
4663 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4667 /* Generate code for the SAME_TYPE_AS intrinsic.
4668 Generate inline code that directly checks the vindices. */
4671 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
4677 gfc_init_se (&se1, NULL);
4678 gfc_init_se (&se2, NULL);
4680 a = expr->value.function.actual->expr;
4681 b = expr->value.function.actual->next->expr;
4683 if (a->ts.type == BT_CLASS)
4685 gfc_add_component_ref (a, "$vptr");
4686 gfc_add_component_ref (a, "$hash");
4688 else if (a->ts.type == BT_DERIVED)
4689 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4690 a->ts.u.derived->hash_value);
4692 if (b->ts.type == BT_CLASS)
4694 gfc_add_component_ref (b, "$vptr");
4695 gfc_add_component_ref (b, "$hash");
4697 else if (b->ts.type == BT_DERIVED)
4698 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4699 b->ts.u.derived->hash_value);
4701 gfc_conv_expr (&se1, a);
4702 gfc_conv_expr (&se2, b);
4704 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4705 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
4706 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4710 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4713 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4717 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4718 se->expr = build_call_expr_loc (input_location,
4719 gfor_fndecl_sc_kind, 2, args[0], args[1]);
4720 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4724 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4727 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4731 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4733 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4734 type = gfc_get_int_type (4);
4735 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4737 /* Convert it to the required type. */
4738 type = gfc_typenode_for_spec (&expr->ts);
4739 se->expr = build_call_expr_loc (input_location,
4740 gfor_fndecl_si_kind, 1, arg);
4741 se->expr = fold_convert (type, se->expr);
4745 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4748 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4750 gfc_actual_arglist *actual;
4755 for (actual = expr->value.function.actual; actual; actual = actual->next)
4757 gfc_init_se (&argse, se);
4759 /* Pass a NULL pointer for an absent arg. */
4760 if (actual->expr == NULL)
4761 argse.expr = null_pointer_node;
4767 if (actual->expr->ts.kind != gfc_c_int_kind)
4769 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4770 ts.type = BT_INTEGER;
4771 ts.kind = gfc_c_int_kind;
4772 gfc_convert_type (actual->expr, &ts, 2);
4774 gfc_conv_expr_reference (&argse, actual->expr);
4777 gfc_add_block_to_block (&se->pre, &argse.pre);
4778 gfc_add_block_to_block (&se->post, &argse.post);
4779 args = gfc_chainon_list (args, argse.expr);
4782 /* Convert it to the required type. */
4783 type = gfc_typenode_for_spec (&expr->ts);
4784 se->expr = build_function_call_expr (input_location,
4785 gfor_fndecl_sr_kind, args);
4786 se->expr = fold_convert (type, se->expr);
4790 /* Generate code for TRIM (A) intrinsic function. */
4793 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4803 unsigned int num_args;
4805 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4806 args = (tree *) alloca (sizeof (tree) * num_args);
4808 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4809 addr = gfc_build_addr_expr (ppvoid_type_node, var);
4810 len = gfc_create_var (gfc_get_int_type (4), "len");
4812 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4813 args[0] = gfc_build_addr_expr (NULL_TREE, len);
4816 if (expr->ts.kind == 1)
4817 function = gfor_fndecl_string_trim;
4818 else if (expr->ts.kind == 4)
4819 function = gfor_fndecl_string_trim_char4;
4823 fndecl = build_addr (function, current_function_decl);
4824 tmp = build_call_array_loc (input_location,
4825 TREE_TYPE (TREE_TYPE (function)), fndecl,
4827 gfc_add_expr_to_block (&se->pre, tmp);
4829 /* Free the temporary afterwards, if necessary. */
4830 cond = fold_build2 (GT_EXPR, boolean_type_node,
4831 len, build_int_cst (TREE_TYPE (len), 0));
4832 tmp = gfc_call_free (var);
4833 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4834 gfc_add_expr_to_block (&se->post, tmp);
4837 se->string_length = len;
4841 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
4844 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4846 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4847 tree type, cond, tmp, count, exit_label, n, max, largest;
4849 stmtblock_t block, body;
4852 /* We store in charsize the size of a character. */
4853 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4854 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4856 /* Get the arguments. */
4857 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4858 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4860 ncopies = gfc_evaluate_now (args[2], &se->pre);
4861 ncopies_type = TREE_TYPE (ncopies);
4863 /* Check that NCOPIES is not negative. */
4864 cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4865 build_int_cst (ncopies_type, 0));
4866 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4867 "Argument NCOPIES of REPEAT intrinsic is negative "
4868 "(its value is %lld)",
4869 fold_convert (long_integer_type_node, ncopies));
4871 /* If the source length is zero, any non negative value of NCOPIES
4872 is valid, and nothing happens. */
4873 n = gfc_create_var (ncopies_type, "ncopies");
4874 cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4875 build_int_cst (size_type_node, 0));
4876 tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4877 build_int_cst (ncopies_type, 0), ncopies);
4878 gfc_add_modify (&se->pre, n, tmp);
4881 /* Check that ncopies is not too large: ncopies should be less than
4882 (or equal to) MAX / slen, where MAX is the maximal integer of
4883 the gfc_charlen_type_node type. If slen == 0, we need a special
4884 case to avoid the division by zero. */
4885 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4886 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4887 max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4888 fold_convert (size_type_node, max), slen);
4889 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4890 ? size_type_node : ncopies_type;
4891 cond = fold_build2 (GT_EXPR, boolean_type_node,
4892 fold_convert (largest, ncopies),
4893 fold_convert (largest, max));
4894 tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4895 build_int_cst (size_type_node, 0));
4896 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4898 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4899 "Argument NCOPIES of REPEAT intrinsic is too large");
4901 /* Compute the destination length. */
4902 dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4903 fold_convert (gfc_charlen_type_node, slen),
4904 fold_convert (gfc_charlen_type_node, ncopies));
4905 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4906 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4908 /* Generate the code to do the repeat operation:
4909 for (i = 0; i < ncopies; i++)
4910 memmove (dest + (i * slen * size), src, slen*size); */
4911 gfc_start_block (&block);
4912 count = gfc_create_var (ncopies_type, "count");
4913 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4914 exit_label = gfc_build_label_decl (NULL_TREE);
4916 /* Start the loop body. */
4917 gfc_start_block (&body);
4919 /* Exit the loop if count >= ncopies. */
4920 cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4921 tmp = build1_v (GOTO_EXPR, exit_label);
4922 TREE_USED (exit_label) = 1;
4923 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4924 build_empty_stmt (input_location));
4925 gfc_add_expr_to_block (&body, tmp);
4927 /* Call memmove (dest + (i*slen*size), src, slen*size). */
4928 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4929 fold_convert (gfc_charlen_type_node, slen),
4930 fold_convert (gfc_charlen_type_node, count));
4931 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4932 tmp, fold_convert (gfc_charlen_type_node, size));
4933 tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4934 fold_convert (pvoid_type_node, dest),
4935 fold_convert (sizetype, tmp));
4936 tmp = build_call_expr_loc (input_location,
4937 built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4938 fold_build2 (MULT_EXPR, size_type_node, slen,
4939 fold_convert (size_type_node, size)));
4940 gfc_add_expr_to_block (&body, tmp);
4942 /* Increment count. */
4943 tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4944 count, build_int_cst (TREE_TYPE (count), 1));
4945 gfc_add_modify (&body, count, tmp);
4947 /* Build the loop. */
4948 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4949 gfc_add_expr_to_block (&block, tmp);
4951 /* Add the exit label. */
4952 tmp = build1_v (LABEL_EXPR, exit_label);
4953 gfc_add_expr_to_block (&block, tmp);
4955 /* Finish the block. */
4956 tmp = gfc_finish_block (&block);
4957 gfc_add_expr_to_block (&se->pre, tmp);
4959 /* Set the result value. */
4961 se->string_length = dlen;
4965 /* Generate code for the IARGC intrinsic. */
4968 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4974 /* Call the library function. This always returns an INTEGER(4). */
4975 fndecl = gfor_fndecl_iargc;
4976 tmp = build_call_expr_loc (input_location,
4979 /* Convert it to the required type. */
4980 type = gfc_typenode_for_spec (&expr->ts);
4981 tmp = fold_convert (type, tmp);
4987 /* The loc intrinsic returns the address of its argument as
4988 gfc_index_integer_kind integer. */
4991 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4997 gcc_assert (!se->ss);
4999 arg_expr = expr->value.function.actual->expr;
5000 ss = gfc_walk_expr (arg_expr);
5001 if (ss == gfc_ss_terminator)
5002 gfc_conv_expr_reference (se, arg_expr);
5004 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
5005 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
5007 /* Create a temporary variable for loc return value. Without this,
5008 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
5009 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
5010 gfc_add_modify (&se->pre, temp_var, se->expr);
5011 se->expr = temp_var;
5014 /* Generate code for an intrinsic function. Some map directly to library
5015 calls, others get special handling. In some cases the name of the function
5016 used depends on the type specifiers. */
5019 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
5025 name = &expr->value.function.name[2];
5027 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
5029 lib = gfc_is_intrinsic_libcall (expr);
5033 se->ignore_optional = 1;
5035 switch (expr->value.function.isym->id)
5037 case GFC_ISYM_EOSHIFT:
5039 case GFC_ISYM_RESHAPE:
5040 /* For all of those the first argument specifies the type and the
5041 third is optional. */
5042 conv_generic_with_optional_char_arg (se, expr, 1, 3);
5046 gfc_conv_intrinsic_funcall (se, expr);
5054 switch (expr->value.function.isym->id)
5059 case GFC_ISYM_REPEAT:
5060 gfc_conv_intrinsic_repeat (se, expr);
5064 gfc_conv_intrinsic_trim (se, expr);
5067 case GFC_ISYM_SC_KIND:
5068 gfc_conv_intrinsic_sc_kind (se, expr);
5071 case GFC_ISYM_SI_KIND:
5072 gfc_conv_intrinsic_si_kind (se, expr);
5075 case GFC_ISYM_SR_KIND:
5076 gfc_conv_intrinsic_sr_kind (se, expr);
5079 case GFC_ISYM_EXPONENT:
5080 gfc_conv_intrinsic_exponent (se, expr);
5084 kind = expr->value.function.actual->expr->ts.kind;
5086 fndecl = gfor_fndecl_string_scan;
5088 fndecl = gfor_fndecl_string_scan_char4;
5092 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5095 case GFC_ISYM_VERIFY:
5096 kind = expr->value.function.actual->expr->ts.kind;
5098 fndecl = gfor_fndecl_string_verify;
5100 fndecl = gfor_fndecl_string_verify_char4;
5104 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5107 case GFC_ISYM_ALLOCATED:
5108 gfc_conv_allocated (se, expr);
5111 case GFC_ISYM_ASSOCIATED:
5112 gfc_conv_associated(se, expr);
5115 case GFC_ISYM_SAME_TYPE_AS:
5116 gfc_conv_same_type_as (se, expr);
5120 gfc_conv_intrinsic_abs (se, expr);
5123 case GFC_ISYM_ADJUSTL:
5124 if (expr->ts.kind == 1)
5125 fndecl = gfor_fndecl_adjustl;
5126 else if (expr->ts.kind == 4)
5127 fndecl = gfor_fndecl_adjustl_char4;
5131 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5134 case GFC_ISYM_ADJUSTR:
5135 if (expr->ts.kind == 1)
5136 fndecl = gfor_fndecl_adjustr;
5137 else if (expr->ts.kind == 4)
5138 fndecl = gfor_fndecl_adjustr_char4;
5142 gfc_conv_intrinsic_adjust (se, expr, fndecl);
5145 case GFC_ISYM_AIMAG:
5146 gfc_conv_intrinsic_imagpart (se, expr);
5150 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
5154 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
5157 case GFC_ISYM_ANINT:
5158 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
5162 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5166 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
5169 case GFC_ISYM_BTEST:
5170 gfc_conv_intrinsic_btest (se, expr);
5173 case GFC_ISYM_ACHAR:
5175 gfc_conv_intrinsic_char (se, expr);
5178 case GFC_ISYM_CONVERSION:
5180 case GFC_ISYM_LOGICAL:
5182 gfc_conv_intrinsic_conversion (se, expr);
5185 /* Integer conversions are handled separately to make sure we get the
5186 correct rounding mode. */
5191 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5195 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5198 case GFC_ISYM_CEILING:
5199 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5202 case GFC_ISYM_FLOOR:
5203 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5207 gfc_conv_intrinsic_mod (se, expr, 0);
5210 case GFC_ISYM_MODULO:
5211 gfc_conv_intrinsic_mod (se, expr, 1);
5214 case GFC_ISYM_CMPLX:
5215 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5218 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5219 gfc_conv_intrinsic_iargc (se, expr);
5222 case GFC_ISYM_COMPLEX:
5223 gfc_conv_intrinsic_cmplx (se, expr, 1);
5226 case GFC_ISYM_CONJG:
5227 gfc_conv_intrinsic_conjg (se, expr);
5230 case GFC_ISYM_COUNT:
5231 gfc_conv_intrinsic_count (se, expr);
5234 case GFC_ISYM_CTIME:
5235 gfc_conv_intrinsic_ctime (se, expr);
5239 gfc_conv_intrinsic_dim (se, expr);
5242 case GFC_ISYM_DOT_PRODUCT:
5243 gfc_conv_intrinsic_dot_product (se, expr);
5246 case GFC_ISYM_DPROD:
5247 gfc_conv_intrinsic_dprod (se, expr);
5250 case GFC_ISYM_FDATE:
5251 gfc_conv_intrinsic_fdate (se, expr);
5254 case GFC_ISYM_FRACTION:
5255 gfc_conv_intrinsic_fraction (se, expr);
5259 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5262 case GFC_ISYM_IBCLR:
5263 gfc_conv_intrinsic_singlebitop (se, expr, 0);
5266 case GFC_ISYM_IBITS:
5267 gfc_conv_intrinsic_ibits (se, expr);
5270 case GFC_ISYM_IBSET:
5271 gfc_conv_intrinsic_singlebitop (se, expr, 1);
5274 case GFC_ISYM_IACHAR:
5275 case GFC_ISYM_ICHAR:
5276 /* We assume ASCII character sequence. */
5277 gfc_conv_intrinsic_ichar (se, expr);
5280 case GFC_ISYM_IARGC:
5281 gfc_conv_intrinsic_iargc (se, expr);
5285 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5288 case GFC_ISYM_INDEX:
5289 kind = expr->value.function.actual->expr->ts.kind;
5291 fndecl = gfor_fndecl_string_index;
5293 fndecl = gfor_fndecl_string_index_char4;
5297 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5301 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5304 case GFC_ISYM_IS_IOSTAT_END:
5305 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5308 case GFC_ISYM_IS_IOSTAT_EOR:
5309 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5312 case GFC_ISYM_ISNAN:
5313 gfc_conv_intrinsic_isnan (se, expr);
5316 case GFC_ISYM_LSHIFT:
5317 gfc_conv_intrinsic_rlshift (se, expr, 0);
5320 case GFC_ISYM_RSHIFT:
5321 gfc_conv_intrinsic_rlshift (se, expr, 1);
5324 case GFC_ISYM_ISHFT:
5325 gfc_conv_intrinsic_ishft (se, expr);
5328 case GFC_ISYM_ISHFTC:
5329 gfc_conv_intrinsic_ishftc (se, expr);
5332 case GFC_ISYM_LEADZ:
5333 gfc_conv_intrinsic_leadz (se, expr);
5336 case GFC_ISYM_TRAILZ:
5337 gfc_conv_intrinsic_trailz (se, expr);
5340 case GFC_ISYM_LBOUND:
5341 gfc_conv_intrinsic_bound (se, expr, 0);
5344 case GFC_ISYM_TRANSPOSE:
5345 if (se->ss && se->ss->useflags)
5347 gfc_conv_tmp_array_ref (se);
5348 gfc_advance_se_ss_chain (se);
5351 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5355 gfc_conv_intrinsic_len (se, expr);
5358 case GFC_ISYM_LEN_TRIM:
5359 gfc_conv_intrinsic_len_trim (se, expr);
5363 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5367 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5371 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5375 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5379 if (expr->ts.type == BT_CHARACTER)
5380 gfc_conv_intrinsic_minmax_char (se, expr, 1);
5382 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5385 case GFC_ISYM_MAXLOC:
5386 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5389 case GFC_ISYM_MAXVAL:
5390 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5393 case GFC_ISYM_MERGE:
5394 gfc_conv_intrinsic_merge (se, expr);
5398 if (expr->ts.type == BT_CHARACTER)
5399 gfc_conv_intrinsic_minmax_char (se, expr, -1);
5401 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5404 case GFC_ISYM_MINLOC:
5405 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5408 case GFC_ISYM_MINVAL:
5409 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5412 case GFC_ISYM_NEAREST:
5413 gfc_conv_intrinsic_nearest (se, expr);
5417 gfc_conv_intrinsic_not (se, expr);
5421 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5424 case GFC_ISYM_PRESENT:
5425 gfc_conv_intrinsic_present (se, expr);
5428 case GFC_ISYM_PRODUCT:
5429 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
5432 case GFC_ISYM_RRSPACING:
5433 gfc_conv_intrinsic_rrspacing (se, expr);
5436 case GFC_ISYM_SET_EXPONENT:
5437 gfc_conv_intrinsic_set_exponent (se, expr);
5440 case GFC_ISYM_SCALE:
5441 gfc_conv_intrinsic_scale (se, expr);
5445 gfc_conv_intrinsic_sign (se, expr);
5449 gfc_conv_intrinsic_size (se, expr);
5452 case GFC_ISYM_SIZEOF:
5453 gfc_conv_intrinsic_sizeof (se, expr);
5456 case GFC_ISYM_SPACING:
5457 gfc_conv_intrinsic_spacing (se, expr);
5461 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
5464 case GFC_ISYM_TRANSFER:
5465 if (se->ss && se->ss->useflags)
5467 /* Access the previously obtained result. */
5468 gfc_conv_tmp_array_ref (se);
5469 gfc_advance_se_ss_chain (se);
5472 gfc_conv_intrinsic_transfer (se, expr);
5475 case GFC_ISYM_TTYNAM:
5476 gfc_conv_intrinsic_ttynam (se, expr);
5479 case GFC_ISYM_UBOUND:
5480 gfc_conv_intrinsic_bound (se, expr, 1);
5484 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5488 gfc_conv_intrinsic_loc (se, expr);
5491 case GFC_ISYM_ACCESS:
5492 case GFC_ISYM_CHDIR:
5493 case GFC_ISYM_CHMOD:
5494 case GFC_ISYM_DTIME:
5495 case GFC_ISYM_ETIME:
5496 case GFC_ISYM_EXTENDS_TYPE_OF:
5498 case GFC_ISYM_FGETC:
5501 case GFC_ISYM_FPUTC:
5502 case GFC_ISYM_FSTAT:
5503 case GFC_ISYM_FTELL:
5504 case GFC_ISYM_GETCWD:
5505 case GFC_ISYM_GETGID:
5506 case GFC_ISYM_GETPID:
5507 case GFC_ISYM_GETUID:
5508 case GFC_ISYM_HOSTNM:
5510 case GFC_ISYM_IERRNO:
5511 case GFC_ISYM_IRAND:
5512 case GFC_ISYM_ISATTY:
5514 case GFC_ISYM_LSTAT:
5515 case GFC_ISYM_MALLOC:
5516 case GFC_ISYM_MATMUL:
5517 case GFC_ISYM_MCLOCK:
5518 case GFC_ISYM_MCLOCK8:
5520 case GFC_ISYM_RENAME:
5521 case GFC_ISYM_SECOND:
5522 case GFC_ISYM_SECNDS:
5523 case GFC_ISYM_SIGNAL:
5525 case GFC_ISYM_SYMLNK:
5526 case GFC_ISYM_SYSTEM:
5528 case GFC_ISYM_TIME8:
5529 case GFC_ISYM_UMASK:
5530 case GFC_ISYM_UNLINK:
5531 gfc_conv_intrinsic_funcall (se, expr);
5534 case GFC_ISYM_EOSHIFT:
5536 case GFC_ISYM_RESHAPE:
5537 /* For those, expr->rank should always be >0 and thus the if above the
5538 switch should have matched. */
5543 gfc_conv_intrinsic_lib_function (se, expr);
5549 /* This generates code to execute before entering the scalarization loop.
5550 Currently does nothing. */
5553 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5555 switch (ss->expr->value.function.isym->id)
5557 case GFC_ISYM_UBOUND:
5558 case GFC_ISYM_LBOUND:
5567 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5568 inside the scalarization loop. */
5571 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5575 /* The two argument version returns a scalar. */
5576 if (expr->value.function.actual->next->expr)
5579 newss = gfc_get_ss ();
5580 newss->type = GFC_SS_INTRINSIC;
5583 newss->data.info.dimen = 1;
5589 /* Walk an intrinsic array libcall. */
5592 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5596 gcc_assert (expr->rank > 0);
5598 newss = gfc_get_ss ();
5599 newss->type = GFC_SS_FUNCTION;
5602 newss->data.info.dimen = expr->rank;
5608 /* Returns nonzero if the specified intrinsic function call maps directly to
5609 an external library call. Should only be used for functions that return
5613 gfc_is_intrinsic_libcall (gfc_expr * expr)
5615 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5616 gcc_assert (expr->rank > 0);
5618 switch (expr->value.function.isym->id)
5622 case GFC_ISYM_COUNT:
5623 case GFC_ISYM_MATMUL:
5624 case GFC_ISYM_MAXLOC:
5625 case GFC_ISYM_MAXVAL:
5626 case GFC_ISYM_MINLOC:
5627 case GFC_ISYM_MINVAL:
5628 case GFC_ISYM_PRODUCT:
5630 case GFC_ISYM_SHAPE:
5631 case GFC_ISYM_SPREAD:
5632 case GFC_ISYM_TRANSPOSE:
5633 /* Ignore absent optional parameters. */
5636 case GFC_ISYM_RESHAPE:
5637 case GFC_ISYM_CSHIFT:
5638 case GFC_ISYM_EOSHIFT:
5640 case GFC_ISYM_UNPACK:
5641 /* Pass absent optional parameters. */
5649 /* Walk an intrinsic function. */
5651 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5652 gfc_intrinsic_sym * isym)
5656 if (isym->elemental)
5657 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5659 if (expr->rank == 0)
5662 if (gfc_is_intrinsic_libcall (expr))
5663 return gfc_walk_intrinsic_libfunc (ss, expr);
5665 /* Special cases. */
5668 case GFC_ISYM_LBOUND:
5669 case GFC_ISYM_UBOUND:
5670 return gfc_walk_intrinsic_bound (ss, expr);
5672 case GFC_ISYM_TRANSFER:
5673 return gfc_walk_intrinsic_libfunc (ss, expr);
5676 /* This probably meant someone forgot to add an intrinsic to the above
5677 list(s) when they implemented it, or something's gone horribly
5683 #include "gt-fortran-trans-intrinsic.h"