1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
32 #include "tree-gimple.h"
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct gfc_intrinsic_map_t GTY(())
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
51 enum gfc_generic_isym_id id;
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, 0, 0, 0, 0, true, \
96 false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
102 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
103 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
106 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
112 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
113 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
116 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
118 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
120 /* Functions built into gcc itself. */
121 #include "mathbuiltins.def"
123 /* Functions in libm. */
124 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
125 pattern for other mathbuiltins.def entries. At present we have no
126 optimizations for this in the common sources. */
127 LIBM_FUNCTION (SCALE, "scalbn", false),
129 /* Functions in libgfortran. */
130 LIBF_FUNCTION (FRACTION, "fraction", false),
131 LIBF_FUNCTION (NEAREST, "nearest", false),
132 LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
135 LIBF_FUNCTION (NONE, NULL, false)
137 #undef DEFINE_MATH_BUILTIN
138 #undef DEFINE_MATH_BUILTIN_C
142 /* Structure for storing components of a floating number to be used by
143 elemental functions to manipulate reals. */
146 tree arg; /* Variable tree to view convert to integer. */
147 tree expn; /* Variable tree to save exponent. */
148 tree frac; /* Variable tree to save fraction. */
149 tree smask; /* Constant tree of sign's mask. */
150 tree emask; /* Constant tree of exponent's mask. */
151 tree fmask; /* Constant tree of fraction's mask. */
152 tree edigits; /* Constant tree of the number of exponent bits. */
153 tree fdigits; /* Constant tree of the number of fraction bits. */
154 tree f1; /* Constant tree of the f1 defined in the real model. */
155 tree bias; /* Constant tree of the bias of exponent in the memory. */
156 tree type; /* Type tree of arg1. */
157 tree mtype; /* Type tree of integer type. Kind is that of arg1. */
162 /* Evaluate the arguments to an intrinsic function. */
165 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
167 gfc_actual_arglist *actual;
169 gfc_intrinsic_arg *formal;
174 formal = expr->value.function.isym->formal;
176 for (actual = expr->value.function.actual; actual; actual = actual->next,
177 formal = formal ? formal->next : NULL)
180 /* Skip omitted optional arguments. */
184 /* Evaluate the parameter. This will substitute scalarized
185 references automatically. */
186 gfc_init_se (&argse, se);
188 if (e->ts.type == BT_CHARACTER)
190 gfc_conv_expr (&argse, e);
191 gfc_conv_string_parameter (&argse);
192 args = gfc_chainon_list (args, argse.string_length);
195 gfc_conv_expr_val (&argse, e);
197 /* If an optional argument is itself an optional dummy argument,
198 check its presence and substitute a null if absent. */
199 if (e->expr_type ==EXPR_VARIABLE
200 && e->symtree->n.sym->attr.optional
203 gfc_conv_missing_dummy (&argse, e, formal->ts);
205 gfc_add_block_to_block (&se->pre, &argse.pre);
206 gfc_add_block_to_block (&se->post, &argse.post);
207 args = gfc_chainon_list (args, argse.expr);
213 /* Conversions between different types are output by the frontend as
214 intrinsic functions. We implement these directly with inline code. */
217 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
222 /* Evaluate the argument. */
223 type = gfc_typenode_for_spec (&expr->ts);
224 gcc_assert (expr->value.function.actual->expr);
225 arg = gfc_conv_intrinsic_function_args (se, expr);
226 arg = TREE_VALUE (arg);
228 /* Conversion from complex to non-complex involves taking the real
229 component of the value. */
230 if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
231 && expr->ts.type != BT_COMPLEX)
235 artype = TREE_TYPE (TREE_TYPE (arg));
236 arg = build1 (REALPART_EXPR, artype, arg);
239 se->expr = convert (type, arg);
242 /* This is needed because the gcc backend only implements
243 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
244 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
245 Similarly for CEILING. */
248 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
255 argtype = TREE_TYPE (arg);
256 arg = gfc_evaluate_now (arg, pblock);
258 intval = convert (type, arg);
259 intval = gfc_evaluate_now (intval, pblock);
261 tmp = convert (argtype, intval);
262 cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
264 tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
265 build_int_cst (type, 1));
266 tmp = build3 (COND_EXPR, type, cond, intval, tmp);
271 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
272 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
275 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
284 argtype = TREE_TYPE (arg);
285 arg = gfc_evaluate_now (arg, pblock);
287 real_from_string (&r, "0.5");
288 pos = build_real (argtype, r);
290 real_from_string (&r, "-0.5");
291 neg = build_real (argtype, r);
293 tmp = gfc_build_const (argtype, integer_zero_node);
294 cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
296 tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
297 tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
298 return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
302 /* Convert a real to an integer using a specific rounding mode.
303 Ideally we would just build the corresponding GENERIC node,
304 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
307 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
313 return build_fixbound_expr (pblock, arg, type, 0);
317 return build_fixbound_expr (pblock, arg, type, 1);
321 return build_round_expr (pblock, arg, type);
324 return build1 (op, type, arg);
329 /* Round a real value using the specified rounding mode.
330 We use a temporary integer of that same kind size as the result.
331 Values larger than those that can be represented by this kind are
332 unchanged, as thay will not be accurate enough to represent the
334 huge = HUGE (KIND (a))
335 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
339 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
350 kind = expr->ts.kind;
353 /* We have builtin functions for some cases. */
396 /* Evaluate the argument. */
397 gcc_assert (expr->value.function.actual->expr);
398 arg = gfc_conv_intrinsic_function_args (se, expr);
400 /* Use a builtin function if one exists. */
401 if (n != END_BUILTINS)
403 tmp = built_in_decls[n];
404 se->expr = build_function_call_expr (tmp, arg);
408 /* This code is probably redundant, but we'll keep it lying around just
410 type = gfc_typenode_for_spec (&expr->ts);
411 arg = TREE_VALUE (arg);
412 arg = gfc_evaluate_now (arg, &se->pre);
414 /* Test if the value is too large to handle sensibly. */
415 gfc_set_model_kind (kind);
417 n = gfc_validate_kind (BT_INTEGER, kind, false);
418 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
419 tmp = gfc_conv_mpfr_to_tree (huge, kind);
420 cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
422 mpfr_neg (huge, huge, GFC_RND_MODE);
423 tmp = gfc_conv_mpfr_to_tree (huge, kind);
424 tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
425 cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
426 itype = gfc_get_int_type (kind);
428 tmp = build_fix_expr (&se->pre, arg, itype, op);
429 tmp = convert (type, tmp);
430 se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
435 /* Convert to an integer using the specified rounding mode. */
438 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
443 /* Evaluate the argument. */
444 type = gfc_typenode_for_spec (&expr->ts);
445 gcc_assert (expr->value.function.actual->expr);
446 arg = gfc_conv_intrinsic_function_args (se, expr);
447 arg = TREE_VALUE (arg);
449 if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
451 /* Conversion to a different integer kind. */
452 se->expr = convert (type, arg);
456 /* Conversion from complex to non-complex involves taking the real
457 component of the value. */
458 if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
459 && expr->ts.type != BT_COMPLEX)
463 artype = TREE_TYPE (TREE_TYPE (arg));
464 arg = build1 (REALPART_EXPR, artype, arg);
467 se->expr = build_fix_expr (&se->pre, arg, type, op);
472 /* Get the imaginary component of a value. */
475 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
479 arg = gfc_conv_intrinsic_function_args (se, expr);
480 arg = TREE_VALUE (arg);
481 se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
485 /* Get the complex conjugate of a value. */
488 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
492 arg = gfc_conv_intrinsic_function_args (se, expr);
493 arg = TREE_VALUE (arg);
494 se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
498 /* Initialize function decls for library functions. The external functions
499 are created as required. Builtin functions are added here. */
502 gfc_build_intrinsic_lib_fndecls (void)
504 gfc_intrinsic_map_t *m;
506 /* Add GCC builtin functions. */
507 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
509 if (m->code_r4 != END_BUILTINS)
510 m->real4_decl = built_in_decls[m->code_r4];
511 if (m->code_r8 != END_BUILTINS)
512 m->real8_decl = built_in_decls[m->code_r8];
513 if (m->code_r10 != END_BUILTINS)
514 m->real10_decl = built_in_decls[m->code_r10];
515 if (m->code_r16 != END_BUILTINS)
516 m->real16_decl = built_in_decls[m->code_r16];
517 if (m->code_c4 != END_BUILTINS)
518 m->complex4_decl = built_in_decls[m->code_c4];
519 if (m->code_c8 != END_BUILTINS)
520 m->complex8_decl = built_in_decls[m->code_c8];
521 if (m->code_c10 != END_BUILTINS)
522 m->complex10_decl = built_in_decls[m->code_c10];
523 if (m->code_c16 != END_BUILTINS)
524 m->complex16_decl = built_in_decls[m->code_c16];
529 /* Create a fndecl for a simple intrinsic library function. */
532 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
537 gfc_actual_arglist *actual;
540 char name[GFC_MAX_SYMBOL_LEN + 3];
543 if (ts->type == BT_REAL)
548 pdecl = &m->real4_decl;
551 pdecl = &m->real8_decl;
554 pdecl = &m->real10_decl;
557 pdecl = &m->real16_decl;
563 else if (ts->type == BT_COMPLEX)
565 gcc_assert (m->complex_available);
570 pdecl = &m->complex4_decl;
573 pdecl = &m->complex8_decl;
576 pdecl = &m->complex10_decl;
579 pdecl = &m->complex16_decl;
593 gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
595 snprintf (name, sizeof (name), "%s%s%s",
596 ts->type == BT_COMPLEX ? "c" : "",
598 ts->kind == 4 ? "f" : "");
602 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
603 ts->type == BT_COMPLEX ? 'c' : 'r',
607 argtypes = NULL_TREE;
608 for (actual = expr->value.function.actual; actual; actual = actual->next)
610 type = gfc_typenode_for_spec (&actual->expr->ts);
611 argtypes = gfc_chainon_list (argtypes, type);
613 argtypes = gfc_chainon_list (argtypes, void_type_node);
614 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
615 fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
617 /* Mark the decl as external. */
618 DECL_EXTERNAL (fndecl) = 1;
619 TREE_PUBLIC (fndecl) = 1;
621 /* Mark it __attribute__((const)), if possible. */
622 TREE_READONLY (fndecl) = m->is_constant;
624 rest_of_decl_compilation (fndecl, 1, 0);
631 /* Convert an intrinsic function into an external or builtin call. */
634 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
636 gfc_intrinsic_map_t *m;
639 gfc_generic_isym_id id;
641 id = expr->value.function.isym->generic_id;
642 /* Find the entry for this function. */
643 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
649 if (m->id == GFC_ISYM_NONE)
651 internal_error ("Intrinsic function %s(%d) not recognized",
652 expr->value.function.name, id);
655 /* Get the decl and generate the call. */
656 args = gfc_conv_intrinsic_function_args (se, expr);
657 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
658 se->expr = build_function_call_expr (fndecl, args);
661 /* Generate code for EXPONENT(X) intrinsic function. */
664 gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
669 args = gfc_conv_intrinsic_function_args (se, expr);
671 a1 = expr->value.function.actual->expr;
675 fndecl = gfor_fndecl_math_exponent4;
678 fndecl = gfor_fndecl_math_exponent8;
681 fndecl = gfor_fndecl_math_exponent10;
684 fndecl = gfor_fndecl_math_exponent16;
690 se->expr = build_function_call_expr (fndecl, args);
693 /* Evaluate a single upper or lower bound. */
694 /* TODO: bound intrinsic generates way too much unnecessary code. */
697 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
699 gfc_actual_arglist *arg;
700 gfc_actual_arglist *arg2;
710 arg = expr->value.function.actual;
715 /* Create an implicit second parameter from the loop variable. */
716 gcc_assert (!arg2->expr);
717 gcc_assert (se->loop->dimen == 1);
718 gcc_assert (se->ss->expr == expr);
719 gfc_advance_se_ss_chain (se);
720 bound = se->loop->loopvar[0];
721 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
726 /* use the passed argument. */
727 gcc_assert (arg->next->expr);
728 gfc_init_se (&argse, NULL);
729 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
730 gfc_add_block_to_block (&se->pre, &argse.pre);
732 /* Convert from one based to zero based. */
733 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
737 /* TODO: don't re-evaluate the descriptor on each iteration. */
738 /* Get a descriptor for the first parameter. */
739 ss = gfc_walk_expr (arg->expr);
740 gcc_assert (ss != gfc_ss_terminator);
741 gfc_init_se (&argse, NULL);
742 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
743 gfc_add_block_to_block (&se->pre, &argse.pre);
744 gfc_add_block_to_block (&se->post, &argse.post);
748 if (INTEGER_CST_P (bound))
750 gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
751 i = TREE_INT_CST_LOW (bound);
752 gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
756 if (flag_bounds_check)
758 bound = gfc_evaluate_now (bound, &se->pre);
759 cond = fold_build2 (LT_EXPR, boolean_type_node,
760 bound, build_int_cst (TREE_TYPE (bound), 0));
761 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
762 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
763 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
764 gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
769 se->expr = gfc_conv_descriptor_ubound(desc, bound);
771 se->expr = gfc_conv_descriptor_lbound(desc, bound);
773 type = gfc_typenode_for_spec (&expr->ts);
774 se->expr = convert (type, se->expr);
779 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
785 args = gfc_conv_intrinsic_function_args (se, expr);
786 gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
787 val = TREE_VALUE (args);
789 switch (expr->value.function.actual->expr->ts.type)
793 se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
797 switch (expr->ts.kind)
812 se->expr = build_function_call_expr (built_in_decls[n], args);
821 /* Create a complex value from one or two real components. */
824 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
831 type = gfc_typenode_for_spec (&expr->ts);
832 arg = gfc_conv_intrinsic_function_args (se, expr);
833 real = convert (TREE_TYPE (type), TREE_VALUE (arg));
835 imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
836 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
838 arg = TREE_VALUE (arg);
839 imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
840 imag = convert (TREE_TYPE (type), imag);
843 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
845 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
848 /* Remainder function MOD(A, P) = A - INT(A / P) * P
849 MODULO(A, P) = A - FLOOR (A / P) * P */
850 /* TODO: MOD(x, 0) */
853 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
865 arg = gfc_conv_intrinsic_function_args (se, expr);
866 arg2 = TREE_VALUE (TREE_CHAIN (arg));
867 arg = TREE_VALUE (arg);
868 type = TREE_TYPE (arg);
870 switch (expr->ts.type)
873 /* Integer case is easy, we've got a builtin op. */
875 se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
877 se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
881 /* Real values we have to do the hard way. */
882 arg = gfc_evaluate_now (arg, &se->pre);
883 arg2 = gfc_evaluate_now (arg2, &se->pre);
885 tmp = build2 (RDIV_EXPR, type, arg, arg2);
886 /* Test if the value is too large to handle sensibly. */
887 gfc_set_model_kind (expr->ts.kind);
889 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
890 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
891 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
892 test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
894 mpfr_neg (huge, huge, GFC_RND_MODE);
895 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
896 test = build2 (GT_EXPR, boolean_type_node, tmp, test);
897 test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
899 itype = gfc_get_int_type (expr->ts.kind);
901 tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
903 tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
904 tmp = convert (type, tmp);
905 tmp = build3 (COND_EXPR, type, test2, tmp, arg);
906 tmp = build2 (MULT_EXPR, type, tmp, arg2);
907 se->expr = build2 (MINUS_EXPR, type, arg, tmp);
916 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
919 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
928 arg = gfc_conv_intrinsic_function_args (se, expr);
929 arg2 = TREE_VALUE (TREE_CHAIN (arg));
930 arg = TREE_VALUE (arg);
931 type = TREE_TYPE (arg);
933 val = build2 (MINUS_EXPR, type, arg, arg2);
934 val = gfc_evaluate_now (val, &se->pre);
936 zero = gfc_build_const (type, integer_zero_node);
937 tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
938 se->expr = build3 (COND_EXPR, type, tmp, zero, val);
942 /* SIGN(A, B) is absolute value of A times sign of B.
943 The real value versions use library functions to ensure the correct
944 handling of negative zero. Integer case implemented as:
945 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
949 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
960 arg = gfc_conv_intrinsic_function_args (se, expr);
961 if (expr->ts.type == BT_REAL)
963 switch (expr->ts.kind)
966 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
969 tmp = built_in_decls[BUILT_IN_COPYSIGN];
973 tmp = built_in_decls[BUILT_IN_COPYSIGNL];
978 se->expr = build_function_call_expr (tmp, arg);
982 arg2 = TREE_VALUE (TREE_CHAIN (arg));
983 arg = TREE_VALUE (arg);
984 type = TREE_TYPE (arg);
985 zero = gfc_build_const (type, integer_zero_node);
987 testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
988 testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
989 tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
990 se->expr = fold_build3 (COND_EXPR, type, tmp,
991 build1 (NEGATE_EXPR, type, arg), arg);
995 /* Test for the presence of an optional argument. */
998 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1002 arg = expr->value.function.actual->expr;
1003 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1004 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1005 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1009 /* Calculate the double precision product of two single precision values. */
1012 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1018 arg = gfc_conv_intrinsic_function_args (se, expr);
1019 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1020 arg = TREE_VALUE (arg);
1022 /* Convert the args to double precision before multiplying. */
1023 type = gfc_typenode_for_spec (&expr->ts);
1024 arg = convert (type, arg);
1025 arg2 = convert (type, arg2);
1026 se->expr = build2 (MULT_EXPR, type, arg, arg2);
1030 /* Return a length one character string containing an ascii character. */
1033 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1039 arg = gfc_conv_intrinsic_function_args (se, expr);
1040 arg = TREE_VALUE (arg);
1042 /* We currently don't support character types != 1. */
1043 gcc_assert (expr->ts.kind == 1);
1044 type = gfc_character1_type_node;
1045 var = gfc_create_var (type, "char");
1047 arg = convert (type, arg);
1048 gfc_add_modify_expr (&se->pre, var, arg);
1049 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1050 se->string_length = integer_one_node;
1055 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1063 tree gfc_int8_type_node = gfc_get_int_type (8);
1065 type = build_pointer_type (gfc_character1_type_node);
1066 var = gfc_create_var (type, "pstr");
1067 len = gfc_create_var (gfc_int8_type_node, "len");
1069 tmp = gfc_conv_intrinsic_function_args (se, expr);
1070 arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1071 arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1072 arglist = chainon (arglist, tmp);
1074 tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
1075 gfc_add_expr_to_block (&se->pre, tmp);
1077 /* Free the temporary afterwards, if necessary. */
1078 cond = build2 (GT_EXPR, boolean_type_node, len,
1079 build_int_cst (TREE_TYPE (len), 0));
1080 arglist = gfc_chainon_list (NULL_TREE, var);
1081 tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1082 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1083 gfc_add_expr_to_block (&se->post, tmp);
1086 se->string_length = len;
1091 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1099 tree gfc_int4_type_node = gfc_get_int_type (4);
1101 type = build_pointer_type (gfc_character1_type_node);
1102 var = gfc_create_var (type, "pstr");
1103 len = gfc_create_var (gfc_int4_type_node, "len");
1105 tmp = gfc_conv_intrinsic_function_args (se, expr);
1106 arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1107 arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1108 arglist = chainon (arglist, tmp);
1110 tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
1111 gfc_add_expr_to_block (&se->pre, tmp);
1113 /* Free the temporary afterwards, if necessary. */
1114 cond = build2 (GT_EXPR, boolean_type_node, len,
1115 build_int_cst (TREE_TYPE (len), 0));
1116 arglist = gfc_chainon_list (NULL_TREE, var);
1117 tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1118 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1119 gfc_add_expr_to_block (&se->post, tmp);
1122 se->string_length = len;
1126 /* Return a character string containing the tty name. */
1129 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1137 tree gfc_int4_type_node = gfc_get_int_type (4);
1139 type = build_pointer_type (gfc_character1_type_node);
1140 var = gfc_create_var (type, "pstr");
1141 len = gfc_create_var (gfc_int4_type_node, "len");
1143 tmp = gfc_conv_intrinsic_function_args (se, expr);
1144 arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1145 arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1146 arglist = chainon (arglist, tmp);
1148 tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
1149 gfc_add_expr_to_block (&se->pre, tmp);
1151 /* Free the temporary afterwards, if necessary. */
1152 cond = build2 (GT_EXPR, boolean_type_node, len,
1153 build_int_cst (TREE_TYPE (len), 0));
1154 arglist = gfc_chainon_list (NULL_TREE, var);
1155 tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1156 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1157 gfc_add_expr_to_block (&se->post, tmp);
1160 se->string_length = len;
1164 /* Get the minimum/maximum value of all the parameters.
1165 minmax (a1, a2, a3, ...)
1178 /* TODO: Mismatching types can occur when specific names are used.
1179 These should be handled during resolution. */
1181 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1192 arg = gfc_conv_intrinsic_function_args (se, expr);
1193 type = gfc_typenode_for_spec (&expr->ts);
1195 limit = TREE_VALUE (arg);
1196 if (TREE_TYPE (limit) != type)
1197 limit = convert (type, limit);
1198 /* Only evaluate the argument once. */
1199 if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1200 limit = gfc_evaluate_now(limit, &se->pre);
1202 mvar = gfc_create_var (type, "M");
1203 elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1204 for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1206 val = TREE_VALUE (arg);
1207 if (TREE_TYPE (val) != type)
1208 val = convert (type, val);
1210 /* Only evaluate the argument once. */
1211 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1212 val = gfc_evaluate_now(val, &se->pre);
1214 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1216 tmp = build2 (op, boolean_type_node, val, limit);
1217 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1218 gfc_add_expr_to_block (&se->pre, tmp);
1219 elsecase = build_empty_stmt ();
1226 /* Create a symbol node for this intrinsic. The symbol from the frontend
1227 has the generic name. */
1230 gfc_get_symbol_for_expr (gfc_expr * expr)
1234 /* TODO: Add symbols for intrinsic function to the global namespace. */
1235 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1236 sym = gfc_new_symbol (expr->value.function.name, NULL);
1239 sym->attr.external = 1;
1240 sym->attr.function = 1;
1241 sym->attr.always_explicit = 1;
1242 sym->attr.proc = PROC_INTRINSIC;
1243 sym->attr.flavor = FL_PROCEDURE;
1247 sym->attr.dimension = 1;
1248 sym->as = gfc_get_array_spec ();
1249 sym->as->type = AS_ASSUMED_SHAPE;
1250 sym->as->rank = expr->rank;
1253 /* TODO: proper argument lists for external intrinsics. */
1257 /* Generate a call to an external intrinsic function. */
1259 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1263 gcc_assert (!se->ss || se->ss->expr == expr);
1266 gcc_assert (expr->rank > 0);
1268 gcc_assert (expr->rank == 0);
1270 sym = gfc_get_symbol_for_expr (expr);
1271 gfc_conv_function_call (se, sym, expr->value.function.actual);
1275 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1295 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1304 gfc_actual_arglist *actual;
1311 gfc_conv_intrinsic_funcall (se, expr);
1315 actual = expr->value.function.actual;
1316 type = gfc_typenode_for_spec (&expr->ts);
1317 /* Initialize the result. */
1318 resvar = gfc_create_var (type, "test");
1320 tmp = convert (type, boolean_true_node);
1322 tmp = convert (type, boolean_false_node);
1323 gfc_add_modify_expr (&se->pre, resvar, tmp);
1325 /* Walk the arguments. */
1326 arrayss = gfc_walk_expr (actual->expr);
1327 gcc_assert (arrayss != gfc_ss_terminator);
1329 /* Initialize the scalarizer. */
1330 gfc_init_loopinfo (&loop);
1331 exit_label = gfc_build_label_decl (NULL_TREE);
1332 TREE_USED (exit_label) = 1;
1333 gfc_add_ss_to_loop (&loop, arrayss);
1335 /* Initialize the loop. */
1336 gfc_conv_ss_startstride (&loop);
1337 gfc_conv_loop_setup (&loop);
1339 gfc_mark_ss_chain_used (arrayss, 1);
1340 /* Generate the loop body. */
1341 gfc_start_scalarized_body (&loop, &body);
1343 /* If the condition matches then set the return value. */
1344 gfc_start_block (&block);
1346 tmp = convert (type, boolean_false_node);
1348 tmp = convert (type, boolean_true_node);
1349 gfc_add_modify_expr (&block, resvar, tmp);
1351 /* And break out of the loop. */
1352 tmp = build1_v (GOTO_EXPR, exit_label);
1353 gfc_add_expr_to_block (&block, tmp);
1355 found = gfc_finish_block (&block);
1357 /* Check this element. */
1358 gfc_init_se (&arrayse, NULL);
1359 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1360 arrayse.ss = arrayss;
1361 gfc_conv_expr_val (&arrayse, actual->expr);
1363 gfc_add_block_to_block (&body, &arrayse.pre);
1364 tmp = build2 (op, boolean_type_node, arrayse.expr,
1365 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1366 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1367 gfc_add_expr_to_block (&body, tmp);
1368 gfc_add_block_to_block (&body, &arrayse.post);
1370 gfc_trans_scalarizing_loops (&loop, &body);
1372 /* Add the exit label. */
1373 tmp = build1_v (LABEL_EXPR, exit_label);
1374 gfc_add_expr_to_block (&loop.pre, tmp);
1376 gfc_add_block_to_block (&se->pre, &loop.pre);
1377 gfc_add_block_to_block (&se->pre, &loop.post);
1378 gfc_cleanup_loop (&loop);
1383 /* COUNT(A) = Number of true elements in A. */
1385 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1392 gfc_actual_arglist *actual;
1398 gfc_conv_intrinsic_funcall (se, expr);
1402 actual = expr->value.function.actual;
1404 type = gfc_typenode_for_spec (&expr->ts);
1405 /* Initialize the result. */
1406 resvar = gfc_create_var (type, "count");
1407 gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1409 /* Walk the arguments. */
1410 arrayss = gfc_walk_expr (actual->expr);
1411 gcc_assert (arrayss != gfc_ss_terminator);
1413 /* Initialize the scalarizer. */
1414 gfc_init_loopinfo (&loop);
1415 gfc_add_ss_to_loop (&loop, arrayss);
1417 /* Initialize the loop. */
1418 gfc_conv_ss_startstride (&loop);
1419 gfc_conv_loop_setup (&loop);
1421 gfc_mark_ss_chain_used (arrayss, 1);
1422 /* Generate the loop body. */
1423 gfc_start_scalarized_body (&loop, &body);
1425 tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1426 build_int_cst (TREE_TYPE (resvar), 1));
1427 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1429 gfc_init_se (&arrayse, NULL);
1430 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1431 arrayse.ss = arrayss;
1432 gfc_conv_expr_val (&arrayse, actual->expr);
1433 tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1435 gfc_add_block_to_block (&body, &arrayse.pre);
1436 gfc_add_expr_to_block (&body, tmp);
1437 gfc_add_block_to_block (&body, &arrayse.post);
1439 gfc_trans_scalarizing_loops (&loop, &body);
1441 gfc_add_block_to_block (&se->pre, &loop.pre);
1442 gfc_add_block_to_block (&se->pre, &loop.post);
1443 gfc_cleanup_loop (&loop);
1448 /* Inline implementation of the sum and product intrinsics. */
1450 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1458 gfc_actual_arglist *actual;
1463 gfc_expr *arrayexpr;
1468 gfc_conv_intrinsic_funcall (se, expr);
1472 type = gfc_typenode_for_spec (&expr->ts);
1473 /* Initialize the result. */
1474 resvar = gfc_create_var (type, "val");
1475 if (op == PLUS_EXPR)
1476 tmp = gfc_build_const (type, integer_zero_node);
1478 tmp = gfc_build_const (type, integer_one_node);
1480 gfc_add_modify_expr (&se->pre, resvar, tmp);
1482 /* Walk the arguments. */
1483 actual = expr->value.function.actual;
1484 arrayexpr = actual->expr;
1485 arrayss = gfc_walk_expr (arrayexpr);
1486 gcc_assert (arrayss != gfc_ss_terminator);
1488 actual = actual->next->next;
1489 gcc_assert (actual);
1490 maskexpr = actual->expr;
1491 if (maskexpr && maskexpr->rank != 0)
1493 maskss = gfc_walk_expr (maskexpr);
1494 gcc_assert (maskss != gfc_ss_terminator);
1499 /* Initialize the scalarizer. */
1500 gfc_init_loopinfo (&loop);
1501 gfc_add_ss_to_loop (&loop, arrayss);
1503 gfc_add_ss_to_loop (&loop, maskss);
1505 /* Initialize the loop. */
1506 gfc_conv_ss_startstride (&loop);
1507 gfc_conv_loop_setup (&loop);
1509 gfc_mark_ss_chain_used (arrayss, 1);
1511 gfc_mark_ss_chain_used (maskss, 1);
1512 /* Generate the loop body. */
1513 gfc_start_scalarized_body (&loop, &body);
1515 /* If we have a mask, only add this element if the mask is set. */
1518 gfc_init_se (&maskse, NULL);
1519 gfc_copy_loopinfo_to_se (&maskse, &loop);
1521 gfc_conv_expr_val (&maskse, maskexpr);
1522 gfc_add_block_to_block (&body, &maskse.pre);
1524 gfc_start_block (&block);
1527 gfc_init_block (&block);
1529 /* Do the actual summation/product. */
1530 gfc_init_se (&arrayse, NULL);
1531 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1532 arrayse.ss = arrayss;
1533 gfc_conv_expr_val (&arrayse, arrayexpr);
1534 gfc_add_block_to_block (&block, &arrayse.pre);
1536 tmp = build2 (op, type, resvar, arrayse.expr);
1537 gfc_add_modify_expr (&block, resvar, tmp);
1538 gfc_add_block_to_block (&block, &arrayse.post);
1542 /* We enclose the above in if (mask) {...} . */
1543 tmp = gfc_finish_block (&block);
1545 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1548 tmp = gfc_finish_block (&block);
1549 gfc_add_expr_to_block (&body, tmp);
1551 gfc_trans_scalarizing_loops (&loop, &body);
1553 /* For a scalar mask, enclose the loop in an if statement. */
1554 if (maskexpr && maskss == NULL)
1556 gfc_init_se (&maskse, NULL);
1557 gfc_conv_expr_val (&maskse, maskexpr);
1558 gfc_init_block (&block);
1559 gfc_add_block_to_block (&block, &loop.pre);
1560 gfc_add_block_to_block (&block, &loop.post);
1561 tmp = gfc_finish_block (&block);
1563 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1564 gfc_add_expr_to_block (&block, tmp);
1565 gfc_add_block_to_block (&se->pre, &block);
1569 gfc_add_block_to_block (&se->pre, &loop.pre);
1570 gfc_add_block_to_block (&se->pre, &loop.post);
1573 gfc_cleanup_loop (&loop);
1579 /* Inline implementation of the dot_product intrinsic. This function
1580 is based on gfc_conv_intrinsic_arith (the previous function). */
1582 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1590 gfc_actual_arglist *actual;
1591 gfc_ss *arrayss1, *arrayss2;
1592 gfc_se arrayse1, arrayse2;
1593 gfc_expr *arrayexpr1, *arrayexpr2;
1595 type = gfc_typenode_for_spec (&expr->ts);
1597 /* Initialize the result. */
1598 resvar = gfc_create_var (type, "val");
1599 if (expr->ts.type == BT_LOGICAL)
1600 tmp = convert (type, integer_zero_node);
1602 tmp = gfc_build_const (type, integer_zero_node);
1604 gfc_add_modify_expr (&se->pre, resvar, tmp);
1606 /* Walk argument #1. */
1607 actual = expr->value.function.actual;
1608 arrayexpr1 = actual->expr;
1609 arrayss1 = gfc_walk_expr (arrayexpr1);
1610 gcc_assert (arrayss1 != gfc_ss_terminator);
1612 /* Walk argument #2. */
1613 actual = actual->next;
1614 arrayexpr2 = actual->expr;
1615 arrayss2 = gfc_walk_expr (arrayexpr2);
1616 gcc_assert (arrayss2 != gfc_ss_terminator);
1618 /* Initialize the scalarizer. */
1619 gfc_init_loopinfo (&loop);
1620 gfc_add_ss_to_loop (&loop, arrayss1);
1621 gfc_add_ss_to_loop (&loop, arrayss2);
1623 /* Initialize the loop. */
1624 gfc_conv_ss_startstride (&loop);
1625 gfc_conv_loop_setup (&loop);
1627 gfc_mark_ss_chain_used (arrayss1, 1);
1628 gfc_mark_ss_chain_used (arrayss2, 1);
1630 /* Generate the loop body. */
1631 gfc_start_scalarized_body (&loop, &body);
1632 gfc_init_block (&block);
1634 /* Make the tree expression for [conjg(]array1[)]. */
1635 gfc_init_se (&arrayse1, NULL);
1636 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
1637 arrayse1.ss = arrayss1;
1638 gfc_conv_expr_val (&arrayse1, arrayexpr1);
1639 if (expr->ts.type == BT_COMPLEX)
1640 arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
1641 gfc_add_block_to_block (&block, &arrayse1.pre);
1643 /* Make the tree expression for array2. */
1644 gfc_init_se (&arrayse2, NULL);
1645 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
1646 arrayse2.ss = arrayss2;
1647 gfc_conv_expr_val (&arrayse2, arrayexpr2);
1648 gfc_add_block_to_block (&block, &arrayse2.pre);
1650 /* Do the actual product and sum. */
1651 if (expr->ts.type == BT_LOGICAL)
1653 tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
1654 tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
1658 tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
1659 tmp = build2 (PLUS_EXPR, type, resvar, tmp);
1661 gfc_add_modify_expr (&block, resvar, tmp);
1663 /* Finish up the loop block and the loop. */
1664 tmp = gfc_finish_block (&block);
1665 gfc_add_expr_to_block (&body, tmp);
1667 gfc_trans_scalarizing_loops (&loop, &body);
1668 gfc_add_block_to_block (&se->pre, &loop.pre);
1669 gfc_add_block_to_block (&se->pre, &loop.post);
1670 gfc_cleanup_loop (&loop);
1677 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1681 stmtblock_t ifblock;
1682 stmtblock_t elseblock;
1689 gfc_actual_arglist *actual;
1694 gfc_expr *arrayexpr;
1701 gfc_conv_intrinsic_funcall (se, expr);
1705 /* Initialize the result. */
1706 pos = gfc_create_var (gfc_array_index_type, "pos");
1707 type = gfc_typenode_for_spec (&expr->ts);
1709 /* Walk the arguments. */
1710 actual = expr->value.function.actual;
1711 arrayexpr = actual->expr;
1712 arrayss = gfc_walk_expr (arrayexpr);
1713 gcc_assert (arrayss != gfc_ss_terminator);
1715 actual = actual->next->next;
1716 gcc_assert (actual);
1717 maskexpr = actual->expr;
1718 if (maskexpr && maskexpr->rank != 0)
1720 maskss = gfc_walk_expr (maskexpr);
1721 gcc_assert (maskss != gfc_ss_terminator);
1726 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1727 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1728 switch (arrayexpr->ts.type)
1731 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1735 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1736 arrayexpr->ts.kind);
1743 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1745 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1746 gfc_add_modify_expr (&se->pre, limit, tmp);
1748 /* Initialize the scalarizer. */
1749 gfc_init_loopinfo (&loop);
1750 gfc_add_ss_to_loop (&loop, arrayss);
1752 gfc_add_ss_to_loop (&loop, maskss);
1754 /* Initialize the loop. */
1755 gfc_conv_ss_startstride (&loop);
1756 gfc_conv_loop_setup (&loop);
1758 gcc_assert (loop.dimen == 1);
1760 /* Initialize the position to zero, following Fortran 2003. We are free
1761 to do this because Fortran 95 allows the result of an entirely false
1762 mask to be processor dependent. */
1763 gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
1765 gfc_mark_ss_chain_used (arrayss, 1);
1767 gfc_mark_ss_chain_used (maskss, 1);
1768 /* Generate the loop body. */
1769 gfc_start_scalarized_body (&loop, &body);
1771 /* If we have a mask, only check this element if the mask is set. */
1774 gfc_init_se (&maskse, NULL);
1775 gfc_copy_loopinfo_to_se (&maskse, &loop);
1777 gfc_conv_expr_val (&maskse, maskexpr);
1778 gfc_add_block_to_block (&body, &maskse.pre);
1780 gfc_start_block (&block);
1783 gfc_init_block (&block);
1785 /* Compare with the current limit. */
1786 gfc_init_se (&arrayse, NULL);
1787 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1788 arrayse.ss = arrayss;
1789 gfc_conv_expr_val (&arrayse, arrayexpr);
1790 gfc_add_block_to_block (&block, &arrayse.pre);
1792 /* We do the following if this is a more extreme value. */
1793 gfc_start_block (&ifblock);
1795 /* Assign the value to the limit... */
1796 gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1798 /* Remember where we are. */
1799 gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1801 ifbody = gfc_finish_block (&ifblock);
1803 /* If it is a more extreme value or pos is still zero. */
1804 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
1805 build2 (op, boolean_type_node, arrayse.expr, limit),
1806 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
1807 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1808 gfc_add_expr_to_block (&block, tmp);
1812 /* We enclose the above in if (mask) {...}. */
1813 tmp = gfc_finish_block (&block);
1815 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1818 tmp = gfc_finish_block (&block);
1819 gfc_add_expr_to_block (&body, tmp);
1821 gfc_trans_scalarizing_loops (&loop, &body);
1823 /* For a scalar mask, enclose the loop in an if statement. */
1824 if (maskexpr && maskss == NULL)
1826 gfc_init_se (&maskse, NULL);
1827 gfc_conv_expr_val (&maskse, maskexpr);
1828 gfc_init_block (&block);
1829 gfc_add_block_to_block (&block, &loop.pre);
1830 gfc_add_block_to_block (&block, &loop.post);
1831 tmp = gfc_finish_block (&block);
1833 /* For the else part of the scalar mask, just initialize
1834 the pos variable the same way as above. */
1836 gfc_init_block (&elseblock);
1837 gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
1838 elsetmp = gfc_finish_block (&elseblock);
1840 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
1841 gfc_add_expr_to_block (&block, tmp);
1842 gfc_add_block_to_block (&se->pre, &block);
1846 gfc_add_block_to_block (&se->pre, &loop.pre);
1847 gfc_add_block_to_block (&se->pre, &loop.post);
1849 gfc_cleanup_loop (&loop);
1851 /* Return a value in the range 1..SIZE(array). */
1852 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1853 gfc_index_one_node);
1854 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
1855 /* And convert to the required type. */
1856 se->expr = convert (type, tmp);
1860 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1869 gfc_actual_arglist *actual;
1874 gfc_expr *arrayexpr;
1880 gfc_conv_intrinsic_funcall (se, expr);
1884 type = gfc_typenode_for_spec (&expr->ts);
1885 /* Initialize the result. */
1886 limit = gfc_create_var (type, "limit");
1887 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1888 switch (expr->ts.type)
1891 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1895 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1902 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1904 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1905 gfc_add_modify_expr (&se->pre, limit, tmp);
1907 /* Walk the arguments. */
1908 actual = expr->value.function.actual;
1909 arrayexpr = actual->expr;
1910 arrayss = gfc_walk_expr (arrayexpr);
1911 gcc_assert (arrayss != gfc_ss_terminator);
1913 actual = actual->next->next;
1914 gcc_assert (actual);
1915 maskexpr = actual->expr;
1916 if (maskexpr && maskexpr->rank != 0)
1918 maskss = gfc_walk_expr (maskexpr);
1919 gcc_assert (maskss != gfc_ss_terminator);
1924 /* Initialize the scalarizer. */
1925 gfc_init_loopinfo (&loop);
1926 gfc_add_ss_to_loop (&loop, arrayss);
1928 gfc_add_ss_to_loop (&loop, maskss);
1930 /* Initialize the loop. */
1931 gfc_conv_ss_startstride (&loop);
1932 gfc_conv_loop_setup (&loop);
1934 gfc_mark_ss_chain_used (arrayss, 1);
1936 gfc_mark_ss_chain_used (maskss, 1);
1937 /* Generate the loop body. */
1938 gfc_start_scalarized_body (&loop, &body);
1940 /* If we have a mask, only add this element if the mask is set. */
1943 gfc_init_se (&maskse, NULL);
1944 gfc_copy_loopinfo_to_se (&maskse, &loop);
1946 gfc_conv_expr_val (&maskse, maskexpr);
1947 gfc_add_block_to_block (&body, &maskse.pre);
1949 gfc_start_block (&block);
1952 gfc_init_block (&block);
1954 /* Compare with the current limit. */
1955 gfc_init_se (&arrayse, NULL);
1956 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1957 arrayse.ss = arrayss;
1958 gfc_conv_expr_val (&arrayse, arrayexpr);
1959 gfc_add_block_to_block (&block, &arrayse.pre);
1961 /* Assign the value to the limit... */
1962 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1964 /* If it is a more extreme value. */
1965 tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1966 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1967 gfc_add_expr_to_block (&block, tmp);
1968 gfc_add_block_to_block (&block, &arrayse.post);
1970 tmp = gfc_finish_block (&block);
1972 /* We enclose the above in if (mask) {...}. */
1973 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1974 gfc_add_expr_to_block (&body, tmp);
1976 gfc_trans_scalarizing_loops (&loop, &body);
1978 /* For a scalar mask, enclose the loop in an if statement. */
1979 if (maskexpr && maskss == NULL)
1981 gfc_init_se (&maskse, NULL);
1982 gfc_conv_expr_val (&maskse, maskexpr);
1983 gfc_init_block (&block);
1984 gfc_add_block_to_block (&block, &loop.pre);
1985 gfc_add_block_to_block (&block, &loop.post);
1986 tmp = gfc_finish_block (&block);
1988 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1989 gfc_add_expr_to_block (&block, tmp);
1990 gfc_add_block_to_block (&se->pre, &block);
1994 gfc_add_block_to_block (&se->pre, &loop.pre);
1995 gfc_add_block_to_block (&se->pre, &loop.post);
1998 gfc_cleanup_loop (&loop);
2003 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2005 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2012 arg = gfc_conv_intrinsic_function_args (se, expr);
2013 arg2 = TREE_VALUE (TREE_CHAIN (arg));
2014 arg = TREE_VALUE (arg);
2015 type = TREE_TYPE (arg);
2017 tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2018 tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
2019 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2020 build_int_cst (type, 0));
2021 type = gfc_typenode_for_spec (&expr->ts);
2022 se->expr = convert (type, tmp);
2025 /* Generate code to perform the specified operation. */
2027 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2033 arg = gfc_conv_intrinsic_function_args (se, expr);
2034 arg2 = TREE_VALUE (TREE_CHAIN (arg));
2035 arg = TREE_VALUE (arg);
2036 type = TREE_TYPE (arg);
2038 se->expr = fold_build2 (op, type, arg, arg2);
2043 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2047 arg = gfc_conv_intrinsic_function_args (se, expr);
2048 arg = TREE_VALUE (arg);
2050 se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2053 /* Set or clear a single bit. */
2055 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2063 arg = gfc_conv_intrinsic_function_args (se, expr);
2064 arg2 = TREE_VALUE (TREE_CHAIN (arg));
2065 arg = TREE_VALUE (arg);
2066 type = TREE_TYPE (arg);
2068 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2074 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2076 se->expr = fold_build2 (op, type, arg, tmp);
2079 /* Extract a sequence of bits.
2080 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2082 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2091 arg = gfc_conv_intrinsic_function_args (se, expr);
2092 arg2 = TREE_CHAIN (arg);
2093 arg3 = TREE_VALUE (TREE_CHAIN (arg2));
2094 arg = TREE_VALUE (arg);
2095 arg2 = TREE_VALUE (arg2);
2096 type = TREE_TYPE (arg);
2098 mask = build_int_cst (NULL_TREE, -1);
2099 mask = build2 (LSHIFT_EXPR, type, mask, arg3);
2100 mask = build1 (BIT_NOT_EXPR, type, mask);
2102 tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
2104 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2107 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2109 : ((shift >= 0) ? i << shift : i >> -shift)
2110 where all shifts are logical shifts. */
2112 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2125 arg = gfc_conv_intrinsic_function_args (se, expr);
2126 arg2 = TREE_VALUE (TREE_CHAIN (arg));
2127 arg = TREE_VALUE (arg);
2128 type = TREE_TYPE (arg);
2129 utype = gfc_unsigned_type (type);
2131 width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
2133 /* Left shift if positive. */
2134 lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
2136 /* Right shift if negative.
2137 We convert to an unsigned type because we want a logical shift.
2138 The standard doesn't define the case of shifting negative
2139 numbers, and we try to be compatible with other compilers, most
2140 notably g77, here. */
2141 rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2142 convert (utype, arg), width));
2144 tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
2145 build_int_cst (TREE_TYPE (arg2), 0));
2146 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2148 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2149 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2151 num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
2152 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2154 se->expr = fold_build3 (COND_EXPR, type, cond,
2155 build_int_cst (type, 0), tmp);
2158 /* Circular shift. AKA rotate or barrel shift. */
2160 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2171 arg = gfc_conv_intrinsic_function_args (se, expr);
2172 arg2 = TREE_CHAIN (arg);
2173 arg3 = TREE_CHAIN (arg2);
2176 /* Use a library function for the 3 parameter version. */
2177 tree int4type = gfc_get_int_type (4);
2179 type = TREE_TYPE (TREE_VALUE (arg));
2180 /* We convert the first argument to at least 4 bytes, and
2181 convert back afterwards. This removes the need for library
2182 functions for all argument sizes, and function will be
2183 aligned to at least 32 bits, so there's no loss. */
2184 if (expr->ts.kind < 4)
2186 tmp = convert (int4type, TREE_VALUE (arg));
2187 TREE_VALUE (arg) = tmp;
2189 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2190 need loads of library functions. They cannot have values >
2191 BIT_SIZE (I) so the conversion is safe. */
2192 TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
2193 TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
2195 switch (expr->ts.kind)
2200 tmp = gfor_fndecl_math_ishftc4;
2203 tmp = gfor_fndecl_math_ishftc8;
2206 tmp = gfor_fndecl_math_ishftc16;
2211 se->expr = build_function_call_expr (tmp, arg);
2212 /* Convert the result back to the original type, if we extended
2213 the first argument's width above. */
2214 if (expr->ts.kind < 4)
2215 se->expr = convert (type, se->expr);
2219 arg = TREE_VALUE (arg);
2220 arg2 = TREE_VALUE (arg2);
2221 type = TREE_TYPE (arg);
2223 /* Rotate left if positive. */
2224 lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
2226 /* Rotate right if negative. */
2227 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
2228 rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
2230 zero = build_int_cst (TREE_TYPE (arg2), 0);
2231 tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
2232 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2234 /* Do nothing if shift == 0. */
2235 tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
2236 se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
2239 /* The length of a character string. */
2241 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2250 gcc_assert (!se->ss);
2252 arg = expr->value.function.actual->expr;
2254 type = gfc_typenode_for_spec (&expr->ts);
2255 switch (arg->expr_type)
2258 len = build_int_cst (NULL_TREE, arg->value.character.length);
2262 /* Obtain the string length from the function used by
2263 trans-array.c(gfc_trans_array_constructor). */
2265 get_array_ctor_strlen (arg->value.constructor, &len);
2269 if (arg->expr_type == EXPR_VARIABLE
2270 && (arg->ref == NULL || (arg->ref->next == NULL
2271 && arg->ref->type == REF_ARRAY)))
2273 /* This doesn't catch all cases.
2274 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2275 and the surrounding thread. */
2276 sym = arg->symtree->n.sym;
2277 decl = gfc_get_symbol_decl (sym);
2278 if (decl == current_function_decl && sym->attr.function
2279 && (sym->result == sym))
2280 decl = gfc_get_fake_result_decl (sym, 0);
2282 len = sym->ts.cl->backend_decl;
2287 /* Anybody stupid enough to do this deserves inefficient code. */
2288 gfc_init_se (&argse, se);
2289 gfc_conv_expr (&argse, arg);
2290 gfc_add_block_to_block (&se->pre, &argse.pre);
2291 gfc_add_block_to_block (&se->post, &argse.post);
2292 len = argse.string_length;
2296 se->expr = convert (type, len);
2299 /* The length of a character string not including trailing blanks. */
2301 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2306 args = gfc_conv_intrinsic_function_args (se, expr);
2307 type = gfc_typenode_for_spec (&expr->ts);
2308 se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
2309 se->expr = convert (type, se->expr);
2313 /* Returns the starting position of a substring within a string. */
2316 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2318 tree logical4_type_node = gfc_get_logical_type (4);
2324 args = gfc_conv_intrinsic_function_args (se, expr);
2325 type = gfc_typenode_for_spec (&expr->ts);
2326 tmp = gfc_advance_chain (args, 3);
2327 if (TREE_CHAIN (tmp) == NULL_TREE)
2329 back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2331 TREE_CHAIN (tmp) = back;
2335 back = TREE_CHAIN (tmp);
2336 TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2339 se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
2340 se->expr = convert (type, se->expr);
2343 /* The ascii value for a single character. */
2345 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2350 arg = gfc_conv_intrinsic_function_args (se, expr);
2351 arg = TREE_VALUE (TREE_CHAIN (arg));
2352 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2353 arg = build1 (NOP_EXPR, pchar_type_node, arg);
2354 type = gfc_typenode_for_spec (&expr->ts);
2356 se->expr = build_fold_indirect_ref (arg);
2357 se->expr = convert (type, se->expr);
2361 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2364 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2373 arg = gfc_conv_intrinsic_function_args (se, expr);
2374 if (expr->ts.type != BT_CHARACTER)
2376 tsource = TREE_VALUE (arg);
2377 arg = TREE_CHAIN (arg);
2378 fsource = TREE_VALUE (arg);
2379 mask = TREE_VALUE (TREE_CHAIN (arg));
2383 /* We do the same as in the non-character case, but the argument
2384 list is different because of the string length arguments. We
2385 also have to set the string length for the result. */
2386 len = TREE_VALUE (arg);
2387 arg = TREE_CHAIN (arg);
2388 tsource = TREE_VALUE (arg);
2389 arg = TREE_CHAIN (TREE_CHAIN (arg));
2390 fsource = TREE_VALUE (arg);
2391 mask = TREE_VALUE (TREE_CHAIN (arg));
2393 se->string_length = len;
2395 type = TREE_TYPE (tsource);
2396 se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2401 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2403 gfc_actual_arglist *actual;
2410 gfc_init_se (&argse, NULL);
2411 actual = expr->value.function.actual;
2413 ss = gfc_walk_expr (actual->expr);
2414 gcc_assert (ss != gfc_ss_terminator);
2415 argse.want_pointer = 1;
2416 argse.data_not_needed = 1;
2417 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2418 gfc_add_block_to_block (&se->pre, &argse.pre);
2419 gfc_add_block_to_block (&se->post, &argse.post);
2420 args = gfc_chainon_list (NULL_TREE, argse.expr);
2422 actual = actual->next;
2425 gfc_init_se (&argse, NULL);
2426 gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2427 gfc_add_block_to_block (&se->pre, &argse.pre);
2428 args = gfc_chainon_list (args, argse.expr);
2429 fndecl = gfor_fndecl_size1;
2432 fndecl = gfor_fndecl_size0;
2434 se->expr = build_function_call_expr (fndecl, args);
2435 type = gfc_typenode_for_spec (&expr->ts);
2436 se->expr = convert (type, se->expr);
2440 /* Intrinsic string comparison functions. */
2443 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2449 args = gfc_conv_intrinsic_function_args (se, expr);
2450 arg2 = TREE_CHAIN (TREE_CHAIN (args));
2452 se->expr = gfc_build_compare_string (TREE_VALUE (args),
2453 TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
2454 TREE_VALUE (TREE_CHAIN (arg2)));
2456 type = gfc_typenode_for_spec (&expr->ts);
2457 se->expr = fold_build2 (op, type, se->expr,
2458 build_int_cst (TREE_TYPE (se->expr), 0));
2461 /* Generate a call to the adjustl/adjustr library function. */
2463 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2471 args = gfc_conv_intrinsic_function_args (se, expr);
2472 len = TREE_VALUE (args);
2474 type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2475 var = gfc_conv_string_tmp (se, type, len);
2476 args = tree_cons (NULL_TREE, var, args);
2478 tmp = build_function_call_expr (fndecl, args);
2479 gfc_add_expr_to_block (&se->pre, tmp);
2481 se->string_length = len;
2485 /* A helper function for gfc_conv_intrinsic_array_transfer to compute
2486 the size of tree expressions in bytes. */
2488 gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
2492 if (e->ts.type == BT_CHARACTER)
2493 tmp = se->string_length;
2498 tmp = gfc_get_element_type (TREE_TYPE (se->expr));
2499 tmp = size_in_bytes (tmp);
2502 tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
2505 return fold_convert (gfc_array_index_type, tmp);
2509 /* Array transfer statement.
2510 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2512 typeof<DEST> = typeof<MOLD>
2514 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2515 sizeof (DEST(0) * SIZE). */
2518 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
2532 gfc_actual_arglist *arg;
2539 gcc_assert (se->loop);
2540 info = &se->ss->data.info;
2542 /* Convert SOURCE. The output from this stage is:-
2543 source_bytes = length of the source in bytes
2544 source = pointer to the source data. */
2545 arg = expr->value.function.actual;
2546 gfc_init_se (&argse, NULL);
2547 ss = gfc_walk_expr (arg->expr);
2549 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
2551 /* Obtain the pointer to source and the length of source in bytes. */
2552 if (ss == gfc_ss_terminator)
2554 gfc_conv_expr_reference (&argse, arg->expr);
2555 source = argse.expr;
2557 /* Obtain the source word length. */
2558 tmp = gfc_size_in_bytes (&argse, arg->expr);
2562 gfc_init_se (&argse, NULL);
2563 argse.want_pointer = 0;
2564 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2565 source = gfc_conv_descriptor_data_get (argse.expr);
2567 /* Repack the source if not a full variable array. */
2568 if (!(arg->expr->expr_type == EXPR_VARIABLE
2569 && arg->expr->ref->u.ar.type == AR_FULL))
2571 tmp = build_fold_addr_expr (argse.expr);
2572 tmp = gfc_chainon_list (NULL_TREE, tmp);
2573 source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
2574 source = gfc_evaluate_now (source, &argse.pre);
2576 /* Free the temporary. */
2577 gfc_start_block (&block);
2578 tmp = convert (pvoid_type_node, source);
2579 tmp = gfc_chainon_list (NULL_TREE, tmp);
2580 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2581 gfc_add_expr_to_block (&block, tmp);
2582 stmt = gfc_finish_block (&block);
2584 /* Clean up if it was repacked. */
2585 gfc_init_block (&block);
2586 tmp = gfc_conv_array_data (argse.expr);
2587 tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
2588 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
2589 gfc_add_expr_to_block (&block, tmp);
2590 gfc_add_block_to_block (&block, &se->post);
2591 gfc_init_block (&se->post);
2592 gfc_add_block_to_block (&se->post, &block);
2595 /* Obtain the source word length. */
2596 tmp = gfc_size_in_bytes (&argse, arg->expr);
2598 /* Obtain the size of the array in bytes. */
2599 extent = gfc_create_var (gfc_array_index_type, NULL);
2600 for (n = 0; n < arg->expr->rank; n++)
2603 idx = gfc_rank_cst[n];
2604 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2605 stride = gfc_conv_descriptor_stride (argse.expr, idx);
2606 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2607 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2608 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
2610 gfc_add_modify_expr (&argse.pre, extent, tmp);
2611 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2612 extent, gfc_index_one_node);
2613 tmp = build2 (MULT_EXPR, gfc_array_index_type,
2618 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2619 gfc_add_block_to_block (&se->pre, &argse.pre);
2620 gfc_add_block_to_block (&se->post, &argse.post);
2622 /* Now convert MOLD. The sole output is:
2623 dest_word_len = destination word length in bytes. */
2626 gfc_init_se (&argse, NULL);
2627 ss = gfc_walk_expr (arg->expr);
2629 if (ss == gfc_ss_terminator)
2631 gfc_conv_expr_reference (&argse, arg->expr);
2633 /* Obtain the source word length. */
2634 tmp = gfc_size_in_bytes (&argse, arg->expr);
2638 gfc_init_se (&argse, NULL);
2639 argse.want_pointer = 0;
2640 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2642 /* Obtain the source word length. */
2643 tmp = gfc_size_in_bytes (&argse, arg->expr);
2646 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
2647 gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
2649 /* Finally convert SIZE, if it is present. */
2651 size_words = gfc_create_var (gfc_array_index_type, NULL);
2655 gfc_init_se (&argse, NULL);
2656 gfc_conv_expr_reference (&argse, arg->expr);
2657 tmp = convert (gfc_array_index_type,
2658 build_fold_indirect_ref (argse.expr));
2659 gfc_add_block_to_block (&se->pre, &argse.pre);
2660 gfc_add_block_to_block (&se->post, &argse.post);
2665 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
2666 if (tmp != NULL_TREE)
2668 tmp = build2 (MULT_EXPR, gfc_array_index_type,
2669 tmp, dest_word_len);
2670 tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
2675 gfc_add_modify_expr (&se->pre, size_bytes, tmp);
2676 gfc_add_modify_expr (&se->pre, size_words,
2677 build2 (CEIL_DIV_EXPR, gfc_array_index_type,
2678 size_bytes, dest_word_len));
2680 /* Evaluate the bounds of the result. If the loop range exists, we have
2681 to check if it is too large. If so, we modify loop->to be consistent
2682 with min(size, size(source)). Otherwise, size is made consistent with
2683 the loop range, so that the right number of bytes is transferred.*/
2684 n = se->loop->order[0];
2685 if (se->loop->to[n] != NULL_TREE)
2687 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2688 se->loop->to[n], se->loop->from[n]);
2689 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2690 tmp, gfc_index_one_node);
2691 tmp = build2 (MIN_EXPR, gfc_array_index_type,
2693 gfc_add_modify_expr (&se->pre, size_words, tmp);
2694 gfc_add_modify_expr (&se->pre, size_bytes,
2695 build2 (MULT_EXPR, gfc_array_index_type,
2696 size_words, dest_word_len));
2697 upper = build2 (PLUS_EXPR, gfc_array_index_type,
2698 size_words, se->loop->from[n]);
2699 upper = build2 (MINUS_EXPR, gfc_array_index_type,
2700 upper, gfc_index_one_node);
2704 upper = build2 (MINUS_EXPR, gfc_array_index_type,
2705 size_words, gfc_index_one_node);
2706 se->loop->from[n] = gfc_index_zero_node;
2709 se->loop->to[n] = upper;
2711 /* Build a destination descriptor, using the pointer, source, as the
2712 data field. This is already allocated so set callee_alloc. */
2713 tmp = gfc_typenode_for_spec (&expr->ts);
2714 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
2715 info, tmp, false, true, false);
2717 /* Use memcpy to do the transfer. */
2718 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2719 args = gfc_chainon_list (NULL_TREE, tmp);
2720 tmp = fold_convert (pvoid_type_node, source);
2721 args = gfc_chainon_list (args, source);
2722 args = gfc_chainon_list (args, size_bytes);
2723 tmp = built_in_decls[BUILT_IN_MEMCPY];
2724 tmp = build_function_call_expr (tmp, args);
2725 gfc_add_expr_to_block (&se->pre, tmp);
2727 se->expr = info->descriptor;
2728 if (expr->ts.type == BT_CHARACTER)
2729 se->string_length = dest_word_len;
2733 /* Scalar transfer statement.
2734 TRANSFER (source, mold) = *(typeof<mold> *)&source. */
2737 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2739 gfc_actual_arglist *arg;
2745 /* Get a pointer to the source. */
2746 arg = expr->value.function.actual;
2747 ss = gfc_walk_expr (arg->expr);
2748 gfc_init_se (&argse, NULL);
2749 if (ss == gfc_ss_terminator)
2750 gfc_conv_expr_reference (&argse, arg->expr);
2752 gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2753 gfc_add_block_to_block (&se->pre, &argse.pre);
2754 gfc_add_block_to_block (&se->post, &argse.post);
2758 type = gfc_typenode_for_spec (&expr->ts);
2759 ptr = convert (build_pointer_type (type), ptr);
2760 if (expr->ts.type == BT_CHARACTER)
2762 gfc_init_se (&argse, NULL);
2763 gfc_conv_expr (&argse, arg->expr);
2764 gfc_add_block_to_block (&se->pre, &argse.pre);
2765 gfc_add_block_to_block (&se->post, &argse.post);
2767 se->string_length = argse.string_length;
2771 se->expr = build_fold_indirect_ref (ptr);
2776 /* Generate code for the ALLOCATED intrinsic.
2777 Generate inline code that directly check the address of the argument. */
2780 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2782 gfc_actual_arglist *arg1;
2787 gfc_init_se (&arg1se, NULL);
2788 arg1 = expr->value.function.actual;
2789 ss1 = gfc_walk_expr (arg1->expr);
2790 arg1se.descriptor_only = 1;
2791 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2793 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
2794 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2795 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2796 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2800 /* Generate code for the ASSOCIATED intrinsic.
2801 If both POINTER and TARGET are arrays, generate a call to library function
2802 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2803 In other cases, generate inline code that directly compare the address of
2804 POINTER with the address of TARGET. */
2807 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2809 gfc_actual_arglist *arg1;
2810 gfc_actual_arglist *arg2;
2818 gfc_init_se (&arg1se, NULL);
2819 gfc_init_se (&arg2se, NULL);
2820 arg1 = expr->value.function.actual;
2822 ss1 = gfc_walk_expr (arg1->expr);
2826 /* No optional target. */
2827 if (ss1 == gfc_ss_terminator)
2829 /* A pointer to a scalar. */
2830 arg1se.want_pointer = 1;
2831 gfc_conv_expr (&arg1se, arg1->expr);
2836 /* A pointer to an array. */
2837 arg1se.descriptor_only = 1;
2838 gfc_conv_expr_lhs (&arg1se, arg1->expr);
2839 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
2841 tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2842 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2847 /* An optional target. */
2848 ss2 = gfc_walk_expr (arg2->expr);
2849 if (ss1 == gfc_ss_terminator)
2851 /* A pointer to a scalar. */
2852 gcc_assert (ss2 == gfc_ss_terminator);
2853 arg1se.want_pointer = 1;
2854 gfc_conv_expr (&arg1se, arg1->expr);
2855 arg2se.want_pointer = 1;
2856 gfc_conv_expr (&arg2se, arg2->expr);
2857 tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2862 /* A pointer to an array, call library function _gfor_associated. */
2863 gcc_assert (ss2 != gfc_ss_terminator);
2865 arg1se.want_pointer = 1;
2866 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2867 args = gfc_chainon_list (args, arg1se.expr);
2868 arg2se.want_pointer = 1;
2869 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2870 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2871 gfc_add_block_to_block (&se->post, &arg2se.post);
2872 args = gfc_chainon_list (args, arg2se.expr);
2873 fndecl = gfor_fndecl_associated;
2874 se->expr = build_function_call_expr (fndecl, args);
2877 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2881 /* Scan a string for any one of the characters in a set of characters. */
2884 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2886 tree logical4_type_node = gfc_get_logical_type (4);
2892 args = gfc_conv_intrinsic_function_args (se, expr);
2893 type = gfc_typenode_for_spec (&expr->ts);
2894 tmp = gfc_advance_chain (args, 3);
2895 if (TREE_CHAIN (tmp) == NULL_TREE)
2897 back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2899 TREE_CHAIN (tmp) = back;
2903 back = TREE_CHAIN (tmp);
2904 TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2907 se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
2908 se->expr = convert (type, se->expr);
2912 /* Verify that a set of characters contains all the characters in a string
2913 by identifying the position of the first character in a string of
2914 characters that does not appear in a given set of characters. */
2917 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2919 tree logical4_type_node = gfc_get_logical_type (4);
2925 args = gfc_conv_intrinsic_function_args (se, expr);
2926 type = gfc_typenode_for_spec (&expr->ts);
2927 tmp = gfc_advance_chain (args, 3);
2928 if (TREE_CHAIN (tmp) == NULL_TREE)
2930 back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2932 TREE_CHAIN (tmp) = back;
2936 back = TREE_CHAIN (tmp);
2937 TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2940 se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
2941 se->expr = convert (type, se->expr);
2944 /* Prepare components and related information of a real number which is
2945 the first argument of a elemental functions to manipulate reals. */
2948 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2949 real_compnt_info * rcs, int all)
2956 tree exponent, fraction;
2960 if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2961 gfc_todo_error ("Non-IEEE floating format");
2963 gcc_assert (expr->expr_type == EXPR_FUNCTION);
2965 arg = gfc_conv_intrinsic_function_args (se, expr);
2966 arg = TREE_VALUE (arg);
2967 rcs->type = TREE_TYPE (arg);
2969 /* Force arg'type to integer by unaffected convert */
2970 a1 = expr->value.function.actual->expr;
2971 masktype = gfc_get_int_type (a1->ts.kind);
2972 rcs->mtype = masktype;
2973 tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2974 arg = gfc_create_var (masktype, "arg");
2975 gfc_add_modify_expr(&se->pre, arg, tmp);
2978 /* Calculate the numbers of bits of exponent, fraction and word */
2979 n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2980 tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2981 rcs->fdigits = convert (masktype, tmp);
2982 wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2983 wbits = convert (masktype, wbits);
2984 rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
2986 /* Form masks for exponent/fraction/sign */
2987 one = gfc_build_const (masktype, integer_one_node);
2988 rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
2989 rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
2990 rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
2991 rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
2993 tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
2994 tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
2995 rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
2999 /* exponent, and fraction */
3000 tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
3001 tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
3002 exponent = gfc_create_var (masktype, "exponent");
3003 gfc_add_modify_expr(&se->pre, exponent, tmp);
3004 rcs->expn = exponent;
3006 tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
3007 fraction = gfc_create_var (masktype, "fraction");
3008 gfc_add_modify_expr(&se->pre, fraction, tmp);
3009 rcs->frac = fraction;
3013 /* Build a call to __builtin_clz. */
3016 call_builtin_clz (tree result_type, tree op0)
3018 tree fn, parms, call;
3019 enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
3021 if (op0_mode == TYPE_MODE (integer_type_node))
3022 fn = built_in_decls[BUILT_IN_CLZ];
3023 else if (op0_mode == TYPE_MODE (long_integer_type_node))
3024 fn = built_in_decls[BUILT_IN_CLZL];
3025 else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
3026 fn = built_in_decls[BUILT_IN_CLZLL];
3030 parms = tree_cons (NULL, op0, NULL);
3031 call = build_function_call_expr (fn, parms);
3033 return convert (result_type, call);
3037 /* Generate code for SPACING (X) intrinsic function.
3038 SPACING (X) = POW (2, e-p)
3042 t = expn - fdigits // e - p.
3043 res = t << fdigits // Form the exponent. Fraction is zero.
3044 if (t < 0) // The result is out of range. Denormalized case.
3049 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3056 real_compnt_info rcs;
3058 prepare_arg_info (se, expr, &rcs, 0);
3060 masktype = rcs.mtype;
3061 fdigits = rcs.fdigits;
3063 zero = gfc_build_const (masktype, integer_zero_node);
3064 tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
3065 tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
3066 tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
3067 cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
3068 t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3069 tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
3070 tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3075 /* Generate code for RRSPACING (X) intrinsic function.
3076 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
3078 So the result's exponent is p. And if X is normalized, X's fraction part
3079 is the result's fraction. If X is denormalized, to get the X's fraction we
3080 shift X's fraction part to left until the first '1' is removed.
3084 if (expn == 0 && frac == 0)
3088 // edigits is the number of exponent bits. Add the sign bit.
3089 sedigits = edigits + 1;
3091 if (expn == 0) // Denormalized case.
3093 t1 = leadzero (frac);
3094 frac = frac << (t1 + 1); //Remove the first '1'.
3095 frac = frac >> (sedigits); //Form the fraction.
3098 //fdigits is the number of fraction bits. Form the exponent.
3101 res = (t << fdigits) | frac;
3106 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3109 tree tmp, t1, t2, cond, cond2;
3111 tree fdigits, fraction;
3112 real_compnt_info rcs;
3114 prepare_arg_info (se, expr, &rcs, 1);
3115 masktype = rcs.mtype;
3116 fdigits = rcs.fdigits;
3117 fraction = rcs.frac;
3118 one = gfc_build_const (masktype, integer_one_node);
3119 zero = gfc_build_const (masktype, integer_zero_node);
3120 t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
3122 t1 = call_builtin_clz (masktype, fraction);
3123 tmp = build2 (PLUS_EXPR, masktype, t1, one);
3124 tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
3125 tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
3126 cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
3127 fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
3129 tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
3130 tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3131 tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
3133 cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
3134 cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
3135 tmp = build3 (COND_EXPR, masktype, cond,
3136 build_int_cst (masktype, 0), tmp);
3138 tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3142 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3145 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3149 args = gfc_conv_intrinsic_function_args (se, expr);
3150 args = TREE_VALUE (args);
3151 args = build_fold_addr_expr (args);
3152 args = tree_cons (NULL_TREE, args, NULL_TREE);
3153 se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
3156 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3159 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3161 gfc_actual_arglist *actual;
3166 for (actual = expr->value.function.actual; actual; actual = actual->next)
3168 gfc_init_se (&argse, se);
3170 /* Pass a NULL pointer for an absent arg. */
3171 if (actual->expr == NULL)
3172 argse.expr = null_pointer_node;
3174 gfc_conv_expr_reference (&argse, actual->expr);
3176 gfc_add_block_to_block (&se->pre, &argse.pre);
3177 gfc_add_block_to_block (&se->post, &argse.post);
3178 args = gfc_chainon_list (args, argse.expr);
3180 se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3184 /* Generate code for TRIM (A) intrinsic function. */
3187 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3189 tree gfc_int4_type_node = gfc_get_int_type (4);
3198 arglist = NULL_TREE;
3200 type = build_pointer_type (gfc_character1_type_node);
3201 var = gfc_create_var (type, "pstr");
3202 addr = gfc_build_addr_expr (ppvoid_type_node, var);
3203 len = gfc_create_var (gfc_int4_type_node, "len");
3205 tmp = gfc_conv_intrinsic_function_args (se, expr);
3206 arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
3207 arglist = gfc_chainon_list (arglist, addr);
3208 arglist = chainon (arglist, tmp);
3210 tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
3211 gfc_add_expr_to_block (&se->pre, tmp);
3213 /* Free the temporary afterwards, if necessary. */
3214 cond = build2 (GT_EXPR, boolean_type_node, len,
3215 build_int_cst (TREE_TYPE (len), 0));
3216 arglist = gfc_chainon_list (NULL_TREE, var);
3217 tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
3218 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3219 gfc_add_expr_to_block (&se->post, tmp);
3222 se->string_length = len;
3226 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3229 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3231 tree gfc_int4_type_node = gfc_get_int_type (4);
3240 args = gfc_conv_intrinsic_function_args (se, expr);
3241 len = TREE_VALUE (args);
3242 tmp = gfc_advance_chain (args, 2);
3243 ncopies = TREE_VALUE (tmp);
3244 len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
3245 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3246 var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
3248 arglist = NULL_TREE;
3249 arglist = gfc_chainon_list (arglist, var);
3250 arglist = chainon (arglist, args);
3251 tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
3252 gfc_add_expr_to_block (&se->pre, tmp);
3255 se->string_length = len;
3259 /* Generate code for the IARGC intrinsic. */
3262 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3268 /* Call the library function. This always returns an INTEGER(4). */
3269 fndecl = gfor_fndecl_iargc;
3270 tmp = build_function_call_expr (fndecl, NULL_TREE);
3272 /* Convert it to the required type. */
3273 type = gfc_typenode_for_spec (&expr->ts);
3274 tmp = fold_convert (type, tmp);
3280 /* The loc intrinsic returns the address of its argument as
3281 gfc_index_integer_kind integer. */
3284 gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
3290 gcc_assert (!se->ss);
3292 arg_expr = expr->value.function.actual->expr;
3293 ss = gfc_walk_expr (arg_expr);
3294 if (ss == gfc_ss_terminator)
3295 gfc_conv_expr_reference (se, arg_expr);
3297 gfc_conv_array_parameter (se, arg_expr, ss, 1);
3298 se->expr= convert (gfc_unsigned_type (long_integer_type_node),
3301 /* Create a temporary variable for loc return value. Without this,
3302 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
3303 temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node),
3305 gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3306 se->expr = temp_var;
3309 /* Generate code for an intrinsic function. Some map directly to library
3310 calls, others get special handling. In some cases the name of the function
3311 used depends on the type specifiers. */
3314 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3316 gfc_intrinsic_sym *isym;
3320 isym = expr->value.function.isym;
3322 name = &expr->value.function.name[2];
3324 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3326 lib = gfc_is_intrinsic_libcall (expr);
3330 se->ignore_optional = 1;
3331 gfc_conv_intrinsic_funcall (se, expr);
3336 switch (expr->value.function.isym->generic_id)
3341 case GFC_ISYM_REPEAT:
3342 gfc_conv_intrinsic_repeat (se, expr);
3346 gfc_conv_intrinsic_trim (se, expr);
3349 case GFC_ISYM_SI_KIND:
3350 gfc_conv_intrinsic_si_kind (se, expr);
3353 case GFC_ISYM_SR_KIND:
3354 gfc_conv_intrinsic_sr_kind (se, expr);
3357 case GFC_ISYM_EXPONENT:
3358 gfc_conv_intrinsic_exponent (se, expr);
3361 case GFC_ISYM_SPACING:
3362 gfc_conv_intrinsic_spacing (se, expr);
3365 case GFC_ISYM_RRSPACING:
3366 gfc_conv_intrinsic_rrspacing (se, expr);
3370 gfc_conv_intrinsic_scan (se, expr);
3373 case GFC_ISYM_VERIFY:
3374 gfc_conv_intrinsic_verify (se, expr);
3377 case GFC_ISYM_ALLOCATED:
3378 gfc_conv_allocated (se, expr);
3381 case GFC_ISYM_ASSOCIATED:
3382 gfc_conv_associated(se, expr);
3386 gfc_conv_intrinsic_abs (se, expr);
3389 case GFC_ISYM_ADJUSTL:
3390 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3393 case GFC_ISYM_ADJUSTR:
3394 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3397 case GFC_ISYM_AIMAG:
3398 gfc_conv_intrinsic_imagpart (se, expr);
3402 gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
3406 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3409 case GFC_ISYM_ANINT:
3410 gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
3414 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3418 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3421 case GFC_ISYM_BTEST:
3422 gfc_conv_intrinsic_btest (se, expr);
3425 case GFC_ISYM_ACHAR:
3427 gfc_conv_intrinsic_char (se, expr);
3430 case GFC_ISYM_CONVERSION:
3432 case GFC_ISYM_LOGICAL:
3434 gfc_conv_intrinsic_conversion (se, expr);
3437 /* Integer conversions are handled separately to make sure we get the
3438 correct rounding mode. */
3440 gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
3444 gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
3447 case GFC_ISYM_CEILING:
3448 gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
3451 case GFC_ISYM_FLOOR:
3452 gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
3456 gfc_conv_intrinsic_mod (se, expr, 0);
3459 case GFC_ISYM_MODULO:
3460 gfc_conv_intrinsic_mod (se, expr, 1);
3463 case GFC_ISYM_CMPLX:
3464 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3467 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3468 gfc_conv_intrinsic_iargc (se, expr);
3471 case GFC_ISYM_COMPLEX:
3472 gfc_conv_intrinsic_cmplx (se, expr, 1);
3475 case GFC_ISYM_CONJG:
3476 gfc_conv_intrinsic_conjg (se, expr);
3479 case GFC_ISYM_COUNT:
3480 gfc_conv_intrinsic_count (se, expr);
3483 case GFC_ISYM_CTIME:
3484 gfc_conv_intrinsic_ctime (se, expr);
3488 gfc_conv_intrinsic_dim (se, expr);
3491 case GFC_ISYM_DOT_PRODUCT:
3492 gfc_conv_intrinsic_dot_product (se, expr);
3495 case GFC_ISYM_DPROD:
3496 gfc_conv_intrinsic_dprod (se, expr);
3499 case GFC_ISYM_FDATE:
3500 gfc_conv_intrinsic_fdate (se, expr);
3504 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3507 case GFC_ISYM_IBCLR:
3508 gfc_conv_intrinsic_singlebitop (se, expr, 0);
3511 case GFC_ISYM_IBITS:
3512 gfc_conv_intrinsic_ibits (se, expr);
3515 case GFC_ISYM_IBSET:
3516 gfc_conv_intrinsic_singlebitop (se, expr, 1);
3519 case GFC_ISYM_IACHAR:
3520 case GFC_ISYM_ICHAR:
3521 /* We assume ASCII character sequence. */
3522 gfc_conv_intrinsic_ichar (se, expr);
3525 case GFC_ISYM_IARGC:
3526 gfc_conv_intrinsic_iargc (se, expr);
3530 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3533 case GFC_ISYM_INDEX:
3534 gfc_conv_intrinsic_index (se, expr);
3538 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3541 case GFC_ISYM_ISHFT:
3542 gfc_conv_intrinsic_ishft (se, expr);
3545 case GFC_ISYM_ISHFTC:
3546 gfc_conv_intrinsic_ishftc (se, expr);
3549 case GFC_ISYM_LBOUND:
3550 gfc_conv_intrinsic_bound (se, expr, 0);
3553 case GFC_ISYM_TRANSPOSE:
3554 if (se->ss && se->ss->useflags)
3556 gfc_conv_tmp_array_ref (se);
3557 gfc_advance_se_ss_chain (se);
3560 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3564 gfc_conv_intrinsic_len (se, expr);
3567 case GFC_ISYM_LEN_TRIM:
3568 gfc_conv_intrinsic_len_trim (se, expr);
3572 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3576 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3580 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3584 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3588 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3591 case GFC_ISYM_MAXLOC:
3592 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3595 case GFC_ISYM_MAXVAL:
3596 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3599 case GFC_ISYM_MERGE:
3600 gfc_conv_intrinsic_merge (se, expr);
3604 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3607 case GFC_ISYM_MINLOC:
3608 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3611 case GFC_ISYM_MINVAL:
3612 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3616 gfc_conv_intrinsic_not (se, expr);
3620 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3623 case GFC_ISYM_PRESENT:
3624 gfc_conv_intrinsic_present (se, expr);
3627 case GFC_ISYM_PRODUCT:
3628 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3632 gfc_conv_intrinsic_sign (se, expr);
3636 gfc_conv_intrinsic_size (se, expr);
3640 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3643 case GFC_ISYM_TRANSFER:
3646 if (se->ss->useflags)
3648 /* Access the previously obtained result. */
3649 gfc_conv_tmp_array_ref (se);
3650 gfc_advance_se_ss_chain (se);
3654 gfc_conv_intrinsic_array_transfer (se, expr);
3657 gfc_conv_intrinsic_transfer (se, expr);
3660 case GFC_ISYM_TTYNAM:
3661 gfc_conv_intrinsic_ttynam (se, expr);
3664 case GFC_ISYM_UBOUND:
3665 gfc_conv_intrinsic_bound (se, expr, 1);
3669 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3673 gfc_conv_intrinsic_loc (se, expr);
3676 case GFC_ISYM_CHDIR:
3677 case GFC_ISYM_ETIME:
3679 case GFC_ISYM_FGETC:
3682 case GFC_ISYM_FPUTC:
3683 case GFC_ISYM_FSTAT:
3684 case GFC_ISYM_FTELL:
3685 case GFC_ISYM_GETCWD:
3686 case GFC_ISYM_GETGID:
3687 case GFC_ISYM_GETPID:
3688 case GFC_ISYM_GETUID:
3689 case GFC_ISYM_HOSTNM:
3691 case GFC_ISYM_IERRNO:
3692 case GFC_ISYM_IRAND:
3693 case GFC_ISYM_ISATTY:
3695 case GFC_ISYM_MALLOC:
3696 case GFC_ISYM_MATMUL:
3698 case GFC_ISYM_RENAME:
3699 case GFC_ISYM_SECOND:
3700 case GFC_ISYM_SECNDS:
3701 case GFC_ISYM_SIGNAL:
3703 case GFC_ISYM_SYMLNK:
3704 case GFC_ISYM_SYSTEM:
3706 case GFC_ISYM_TIME8:
3707 case GFC_ISYM_UMASK:
3708 case GFC_ISYM_UNLINK:
3709 gfc_conv_intrinsic_funcall (se, expr);
3713 gfc_conv_intrinsic_lib_function (se, expr);
3719 /* This generates code to execute before entering the scalarization loop.
3720 Currently does nothing. */
3723 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3725 switch (ss->expr->value.function.isym->generic_id)
3727 case GFC_ISYM_UBOUND:
3728 case GFC_ISYM_LBOUND:
3737 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3738 inside the scalarization loop. */
3741 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3745 /* The two argument version returns a scalar. */
3746 if (expr->value.function.actual->next->expr)
3749 newss = gfc_get_ss ();
3750 newss->type = GFC_SS_INTRINSIC;
3753 newss->data.info.dimen = 1;
3759 /* Walk an intrinsic array libcall. */
3762 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3766 gcc_assert (expr->rank > 0);
3768 newss = gfc_get_ss ();
3769 newss->type = GFC_SS_FUNCTION;
3772 newss->data.info.dimen = expr->rank;
3778 /* Returns nonzero if the specified intrinsic function call maps directly to a
3779 an external library call. Should only be used for functions that return
3783 gfc_is_intrinsic_libcall (gfc_expr * expr)
3785 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3786 gcc_assert (expr->rank > 0);
3788 switch (expr->value.function.isym->generic_id)
3792 case GFC_ISYM_COUNT:
3793 case GFC_ISYM_MATMUL:
3794 case GFC_ISYM_MAXLOC:
3795 case GFC_ISYM_MAXVAL:
3796 case GFC_ISYM_MINLOC:
3797 case GFC_ISYM_MINVAL:
3798 case GFC_ISYM_PRODUCT:
3800 case GFC_ISYM_SHAPE:
3801 case GFC_ISYM_SPREAD:
3802 case GFC_ISYM_TRANSPOSE:
3803 /* Ignore absent optional parameters. */
3806 case GFC_ISYM_RESHAPE:
3807 case GFC_ISYM_CSHIFT:
3808 case GFC_ISYM_EOSHIFT:
3810 case GFC_ISYM_UNPACK:
3811 /* Pass absent optional parameters. */
3819 /* Walk an intrinsic function. */
3821 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3822 gfc_intrinsic_sym * isym)
3826 if (isym->elemental)
3827 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
3829 if (expr->rank == 0)
3832 if (gfc_is_intrinsic_libcall (expr))
3833 return gfc_walk_intrinsic_libfunc (ss, expr);
3835 /* Special cases. */
3836 switch (isym->generic_id)
3838 case GFC_ISYM_LBOUND:
3839 case GFC_ISYM_UBOUND:
3840 return gfc_walk_intrinsic_bound (ss, expr);
3842 case GFC_ISYM_TRANSFER:
3843 return gfc_walk_intrinsic_libfunc (ss, expr);
3846 /* This probably meant someone forgot to add an intrinsic to the above
3847 list(s) when they implemented it, or something's gone horribly wrong.
3849 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3850 expr->value.function.name);
3854 #include "gt-fortran-trans-intrinsic.h"