1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 /* This maps fortran intrinsic math functions to external library or GCC
48 typedef struct gfc_intrinsic_map_t GTY(())
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function code_r4;
57 enum built_in_function code_r8;
58 enum built_in_function code_r10;
59 enum built_in_function code_r16;
60 enum built_in_function code_c4;
61 enum built_in_function code_c8;
62 enum built_in_function code_c10;
63 enum built_in_function code_c16;
65 /* True if the naming pattern is to prepend "c" for complex and
66 append "f" for kind=4. False if the naming pattern is to
67 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
70 /* True if a complex version of the function exists. */
71 bool complex_available;
73 /* True if the function should be marked const. */
76 /* The base library name of this function. */
79 /* Cache decls created for the various operand types. */
91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 defines complex variants of all of the entries in mathbuiltins.def
94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
97 false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
103 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
104 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
107 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
108 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
115 /* Functions built into gcc itself. */
116 #include "mathbuiltins.def"
118 /* Functions in libgfortran. */
119 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
122 LIB_FUNCTION (NONE, NULL, false)
126 #undef DEFINE_MATH_BUILTIN
127 #undef DEFINE_MATH_BUILTIN_C
129 /* Structure for storing components of a floating number to be used by
130 elemental functions to manipulate reals. */
133 tree arg; /* Variable tree to view convert to integer. */
134 tree expn; /* Variable tree to save exponent. */
135 tree frac; /* Variable tree to save fraction. */
136 tree smask; /* Constant tree of sign's mask. */
137 tree emask; /* Constant tree of exponent's mask. */
138 tree fmask; /* Constant tree of fraction's mask. */
139 tree edigits; /* Constant tree of the number of exponent bits. */
140 tree fdigits; /* Constant tree of the number of fraction bits. */
141 tree f1; /* Constant tree of the f1 defined in the real model. */
142 tree bias; /* Constant tree of the bias of exponent in the memory. */
143 tree type; /* Type tree of arg1. */
144 tree mtype; /* Type tree of integer type. Kind is that of arg1. */
148 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
150 /* Evaluate the arguments to an intrinsic function. The value
151 of NARGS may be less than the actual number of arguments in EXPR
152 to allow optional "KIND" arguments that are not included in the
153 generated code to be ignored. */
156 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
157 tree *argarray, int nargs)
159 gfc_actual_arglist *actual;
161 gfc_intrinsic_arg *formal;
165 formal = expr->value.function.isym->formal;
166 actual = expr->value.function.actual;
168 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
169 actual = actual->next,
170 formal = formal ? formal->next : NULL)
174 /* Skip omitted optional arguments. */
181 /* Evaluate the parameter. This will substitute scalarized
182 references automatically. */
183 gfc_init_se (&argse, se);
185 if (e->ts.type == BT_CHARACTER)
187 gfc_conv_expr (&argse, e);
188 gfc_conv_string_parameter (&argse);
189 argarray[curr_arg++] = argse.string_length;
190 gcc_assert (curr_arg < nargs);
193 gfc_conv_expr_val (&argse, e);
195 /* If an optional argument is itself an optional dummy argument,
196 check its presence and substitute a null if absent. */
197 if (e->expr_type == EXPR_VARIABLE
198 && e->symtree->n.sym->attr.optional
201 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
203 gfc_add_block_to_block (&se->pre, &argse.pre);
204 gfc_add_block_to_block (&se->post, &argse.post);
205 argarray[curr_arg] = argse.expr;
209 /* Count the number of actual arguments to the intrinsic function EXPR
210 including any "hidden" string length arguments. */
213 gfc_intrinsic_argument_list_length (gfc_expr *expr)
216 gfc_actual_arglist *actual;
218 for (actual = expr->value.function.actual; actual; actual = actual->next)
223 if (actual->expr->ts.type == BT_CHARACTER)
233 /* Conversions between different types are output by the frontend as
234 intrinsic functions. We implement these directly with inline code. */
237 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
243 nargs = gfc_intrinsic_argument_list_length (expr);
244 args = (tree *) alloca (sizeof (tree) * nargs);
246 /* Evaluate all the arguments passed. Whilst we're only interested in the
247 first one here, there are other parts of the front-end that assume this
248 and will trigger an ICE if it's not the case. */
249 type = gfc_typenode_for_spec (&expr->ts);
250 gcc_assert (expr->value.function.actual->expr);
251 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
253 /* Conversion between character kinds involves a call to a library
255 if (expr->ts.type == BT_CHARACTER)
257 tree fndecl, var, addr, tmp;
259 if (expr->ts.kind == 1
260 && expr->value.function.actual->expr->ts.kind == 4)
261 fndecl = gfor_fndecl_convert_char4_to_char1;
262 else if (expr->ts.kind == 4
263 && expr->value.function.actual->expr->ts.kind == 1)
264 fndecl = gfor_fndecl_convert_char1_to_char4;
268 /* Create the variable storing the converted value. */
269 type = gfc_get_pchar_type (expr->ts.kind);
270 var = gfc_create_var (type, "str");
271 addr = gfc_build_addr_expr (build_pointer_type (type), var);
273 /* Call the library function that will perform the conversion. */
274 gcc_assert (nargs >= 2);
275 tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
276 gfc_add_expr_to_block (&se->pre, tmp);
278 /* Free the temporary afterwards. */
279 tmp = gfc_call_free (var);
280 gfc_add_expr_to_block (&se->post, tmp);
283 se->string_length = args[0];
288 /* Conversion from complex to non-complex involves taking the real
289 component of the value. */
290 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
291 && expr->ts.type != BT_COMPLEX)
295 artype = TREE_TYPE (TREE_TYPE (args[0]));
296 args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
299 se->expr = convert (type, args[0]);
302 /* This is needed because the gcc backend only implements
303 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
304 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
305 Similarly for CEILING. */
308 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
315 argtype = TREE_TYPE (arg);
316 arg = gfc_evaluate_now (arg, pblock);
318 intval = convert (type, arg);
319 intval = gfc_evaluate_now (intval, pblock);
321 tmp = convert (argtype, intval);
322 cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
324 tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
325 build_int_cst (type, 1));
326 tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
331 /* Round to nearest integer, away from zero. */
334 build_round_expr (tree arg, tree restype)
339 int argprec, resprec;
341 argtype = TREE_TYPE (arg);
342 argprec = TYPE_PRECISION (argtype);
343 resprec = TYPE_PRECISION (restype);
345 /* Depending on the type of the result, choose the long int intrinsic
346 (lround family) or long long intrinsic (llround). We might also
347 need to convert the result afterwards. */
348 if (resprec <= LONG_TYPE_SIZE)
350 else if (resprec <= LONG_LONG_TYPE_SIZE)
355 /* Now, depending on the argument type, we choose between intrinsics. */
356 if (argprec == TYPE_PRECISION (float_type_node))
357 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
358 else if (argprec == TYPE_PRECISION (double_type_node))
359 fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
360 else if (argprec == TYPE_PRECISION (long_double_type_node))
361 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
365 return fold_convert (restype, build_call_expr (fn, 1, arg));
369 /* Convert a real to an integer using a specific rounding mode.
370 Ideally we would just build the corresponding GENERIC node,
371 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
374 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
375 enum rounding_mode op)
380 return build_fixbound_expr (pblock, arg, type, 0);
384 return build_fixbound_expr (pblock, arg, type, 1);
388 return build_round_expr (arg, type);
392 return fold_build1 (FIX_TRUNC_EXPR, type, arg);
401 /* Round a real value using the specified rounding mode.
402 We use a temporary integer of that same kind size as the result.
403 Values larger than those that can be represented by this kind are
404 unchanged, as they will not be accurate enough to represent the
406 huge = HUGE (KIND (a))
407 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
411 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
422 kind = expr->ts.kind;
423 nargs = gfc_intrinsic_argument_list_length (expr);
426 /* We have builtin functions for some cases. */
469 /* Evaluate the argument. */
470 gcc_assert (expr->value.function.actual->expr);
471 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
473 /* Use a builtin function if one exists. */
474 if (n != END_BUILTINS)
476 tmp = built_in_decls[n];
477 se->expr = build_call_expr (tmp, 1, arg[0]);
481 /* This code is probably redundant, but we'll keep it lying around just
483 type = gfc_typenode_for_spec (&expr->ts);
484 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
486 /* Test if the value is too large to handle sensibly. */
487 gfc_set_model_kind (kind);
489 n = gfc_validate_kind (BT_INTEGER, kind, false);
490 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
491 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
492 cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
494 mpfr_neg (huge, huge, GFC_RND_MODE);
495 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
496 tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
497 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
498 itype = gfc_get_int_type (kind);
500 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
501 tmp = convert (type, tmp);
502 se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
507 /* Convert to an integer using the specified rounding mode. */
510 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
516 nargs = gfc_intrinsic_argument_list_length (expr);
517 args = (tree *) alloca (sizeof (tree) * nargs);
519 /* Evaluate the argument, we process all arguments even though we only
520 use the first one for code generation purposes. */
521 type = gfc_typenode_for_spec (&expr->ts);
522 gcc_assert (expr->value.function.actual->expr);
523 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
525 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
527 /* Conversion to a different integer kind. */
528 se->expr = convert (type, args[0]);
532 /* Conversion from complex to non-complex involves taking the real
533 component of the value. */
534 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
535 && expr->ts.type != BT_COMPLEX)
539 artype = TREE_TYPE (TREE_TYPE (args[0]));
540 args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
543 se->expr = build_fix_expr (&se->pre, args[0], type, op);
548 /* Get the imaginary component of a value. */
551 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
555 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
556 se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
560 /* Get the complex conjugate of a value. */
563 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
567 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
568 se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
572 /* Initialize function decls for library functions. The external functions
573 are created as required. Builtin functions are added here. */
576 gfc_build_intrinsic_lib_fndecls (void)
578 gfc_intrinsic_map_t *m;
580 /* Add GCC builtin functions. */
581 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
583 if (m->code_r4 != END_BUILTINS)
584 m->real4_decl = built_in_decls[m->code_r4];
585 if (m->code_r8 != END_BUILTINS)
586 m->real8_decl = built_in_decls[m->code_r8];
587 if (m->code_r10 != END_BUILTINS)
588 m->real10_decl = built_in_decls[m->code_r10];
589 if (m->code_r16 != END_BUILTINS)
590 m->real16_decl = built_in_decls[m->code_r16];
591 if (m->code_c4 != END_BUILTINS)
592 m->complex4_decl = built_in_decls[m->code_c4];
593 if (m->code_c8 != END_BUILTINS)
594 m->complex8_decl = built_in_decls[m->code_c8];
595 if (m->code_c10 != END_BUILTINS)
596 m->complex10_decl = built_in_decls[m->code_c10];
597 if (m->code_c16 != END_BUILTINS)
598 m->complex16_decl = built_in_decls[m->code_c16];
603 /* Create a fndecl for a simple intrinsic library function. */
606 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
611 gfc_actual_arglist *actual;
614 char name[GFC_MAX_SYMBOL_LEN + 3];
617 if (ts->type == BT_REAL)
622 pdecl = &m->real4_decl;
625 pdecl = &m->real8_decl;
628 pdecl = &m->real10_decl;
631 pdecl = &m->real16_decl;
637 else if (ts->type == BT_COMPLEX)
639 gcc_assert (m->complex_available);
644 pdecl = &m->complex4_decl;
647 pdecl = &m->complex8_decl;
650 pdecl = &m->complex10_decl;
653 pdecl = &m->complex16_decl;
668 snprintf (name, sizeof (name), "%s%s%s",
669 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
670 else if (ts->kind == 8)
671 snprintf (name, sizeof (name), "%s%s",
672 ts->type == BT_COMPLEX ? "c" : "", m->name);
675 gcc_assert (ts->kind == 10 || ts->kind == 16);
676 snprintf (name, sizeof (name), "%s%s%s",
677 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
682 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
683 ts->type == BT_COMPLEX ? 'c' : 'r',
687 argtypes = NULL_TREE;
688 for (actual = expr->value.function.actual; actual; actual = actual->next)
690 type = gfc_typenode_for_spec (&actual->expr->ts);
691 argtypes = gfc_chainon_list (argtypes, type);
693 argtypes = gfc_chainon_list (argtypes, void_type_node);
694 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
695 fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
697 /* Mark the decl as external. */
698 DECL_EXTERNAL (fndecl) = 1;
699 TREE_PUBLIC (fndecl) = 1;
701 /* Mark it __attribute__((const)), if possible. */
702 TREE_READONLY (fndecl) = m->is_constant;
704 rest_of_decl_compilation (fndecl, 1, 0);
711 /* Convert an intrinsic function into an external or builtin call. */
714 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
716 gfc_intrinsic_map_t *m;
720 unsigned int num_args;
723 id = expr->value.function.isym->id;
724 /* Find the entry for this function. */
725 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
731 if (m->id == GFC_ISYM_NONE)
733 internal_error ("Intrinsic function %s(%d) not recognized",
734 expr->value.function.name, id);
737 /* Get the decl and generate the call. */
738 num_args = gfc_intrinsic_argument_list_length (expr);
739 args = (tree *) alloca (sizeof (tree) * num_args);
741 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
742 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
743 rettype = TREE_TYPE (TREE_TYPE (fndecl));
745 fndecl = build_addr (fndecl, current_function_decl);
746 se->expr = build_call_array (rettype, fndecl, num_args, args);
750 /* If bounds-checking is enabled, create code to verify at runtime that the
751 string lengths for both expressions are the same (needed for e.g. MERGE).
752 If bounds-checking is not enabled, does nothing. */
755 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
756 tree a, tree b, stmtblock_t* target)
761 /* If bounds-checking is disabled, do nothing. */
762 if (!flag_bounds_check)
765 /* Compare the two string lengths. */
766 cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
768 /* Output the runtime-check. */
769 name = gfc_build_cstring_const (intr_name);
770 name = gfc_build_addr_expr (pchar_type_node, name);
771 gfc_trans_runtime_check (true, false, cond, target, where,
772 "Unequal character lengths (%ld/%ld) in %s",
773 fold_convert (long_integer_type_node, a),
774 fold_convert (long_integer_type_node, b), name);
778 /* The EXPONENT(s) intrinsic function is translated into
785 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
787 tree arg, type, res, tmp;
790 switch (expr->value.function.actual->expr->ts.kind)
793 frexp = BUILT_IN_FREXPF;
796 frexp = BUILT_IN_FREXP;
800 frexp = BUILT_IN_FREXPL;
806 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
808 res = gfc_create_var (integer_type_node, NULL);
809 tmp = build_call_expr (built_in_decls[frexp], 2, arg,
810 gfc_build_addr_expr (NULL_TREE, res));
811 gfc_add_expr_to_block (&se->pre, tmp);
813 type = gfc_typenode_for_spec (&expr->ts);
814 se->expr = fold_convert (type, res);
817 /* Evaluate a single upper or lower bound. */
818 /* TODO: bound intrinsic generates way too much unnecessary code. */
821 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
823 gfc_actual_arglist *arg;
824 gfc_actual_arglist *arg2;
829 tree cond, cond1, cond2, cond3, cond4, size;
837 arg = expr->value.function.actual;
842 /* Create an implicit second parameter from the loop variable. */
843 gcc_assert (!arg2->expr);
844 gcc_assert (se->loop->dimen == 1);
845 gcc_assert (se->ss->expr == expr);
846 gfc_advance_se_ss_chain (se);
847 bound = se->loop->loopvar[0];
848 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
853 /* use the passed argument. */
854 gcc_assert (arg->next->expr);
855 gfc_init_se (&argse, NULL);
856 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
857 gfc_add_block_to_block (&se->pre, &argse.pre);
859 /* Convert from one based to zero based. */
860 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
864 /* TODO: don't re-evaluate the descriptor on each iteration. */
865 /* Get a descriptor for the first parameter. */
866 ss = gfc_walk_expr (arg->expr);
867 gcc_assert (ss != gfc_ss_terminator);
868 gfc_init_se (&argse, NULL);
869 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
870 gfc_add_block_to_block (&se->pre, &argse.pre);
871 gfc_add_block_to_block (&se->post, &argse.post);
875 if (INTEGER_CST_P (bound))
879 hi = TREE_INT_CST_HIGH (bound);
880 low = TREE_INT_CST_LOW (bound);
881 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
882 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
883 "dimension index", upper ? "UBOUND" : "LBOUND",
888 if (flag_bounds_check)
890 bound = gfc_evaluate_now (bound, &se->pre);
891 cond = fold_build2 (LT_EXPR, boolean_type_node,
892 bound, build_int_cst (TREE_TYPE (bound), 0));
893 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
894 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
895 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
896 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
901 ubound = gfc_conv_descriptor_ubound (desc, bound);
902 lbound = gfc_conv_descriptor_lbound (desc, bound);
904 /* Follow any component references. */
905 if (arg->expr->expr_type == EXPR_VARIABLE
906 || arg->expr->expr_type == EXPR_CONSTANT)
908 as = arg->expr->symtree->n.sym->as;
909 for (ref = arg->expr->ref; ref; ref = ref->next)
914 as = ref->u.c.component->as;
922 switch (ref->u.ar.type)
941 /* 13.14.53: Result value for LBOUND
943 Case (i): For an array section or for an array expression other than a
944 whole array or array structure component, LBOUND(ARRAY, DIM)
945 has the value 1. For a whole array or array structure
946 component, LBOUND(ARRAY, DIM) has the value:
947 (a) equal to the lower bound for subscript DIM of ARRAY if
948 dimension DIM of ARRAY does not have extent zero
949 or if ARRAY is an assumed-size array of rank DIM,
952 13.14.113: Result value for UBOUND
954 Case (i): For an array section or for an array expression other than a
955 whole array or array structure component, UBOUND(ARRAY, DIM)
956 has the value equal to the number of elements in the given
957 dimension; otherwise, it has a value equal to the upper bound
958 for subscript DIM of ARRAY if dimension DIM of ARRAY does
959 not have size zero and has value zero if dimension DIM has
964 tree stride = gfc_conv_descriptor_stride (desc, bound);
966 cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
967 cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
969 cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
970 gfc_index_zero_node);
971 cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
973 cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
974 gfc_index_zero_node);
979 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
981 cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
982 cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
984 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
986 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
987 ubound, gfc_index_zero_node);
991 if (as->type == AS_ASSUMED_SIZE)
992 cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
993 build_int_cst (TREE_TYPE (bound),
994 arg->expr->rank - 1));
996 cond = boolean_false_node;
998 cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
999 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
1001 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1002 lbound, gfc_index_one_node);
1009 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
1010 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
1011 gfc_index_one_node);
1012 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
1013 gfc_index_zero_node);
1016 se->expr = gfc_index_one_node;
1019 type = gfc_typenode_for_spec (&expr->ts);
1020 se->expr = convert (type, se->expr);
1025 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1030 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1032 switch (expr->value.function.actual->expr->ts.type)
1036 se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1040 switch (expr->ts.kind)
1055 se->expr = build_call_expr (built_in_decls[n], 1, arg);
1064 /* Create a complex value from one or two real components. */
1067 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1073 unsigned int num_args;
1075 num_args = gfc_intrinsic_argument_list_length (expr);
1076 args = (tree *) alloca (sizeof (tree) * num_args);
1078 type = gfc_typenode_for_spec (&expr->ts);
1079 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1080 real = convert (TREE_TYPE (type), args[0]);
1082 imag = convert (TREE_TYPE (type), args[1]);
1083 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1085 imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1087 imag = convert (TREE_TYPE (type), imag);
1090 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1092 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1095 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1096 MODULO(A, P) = A - FLOOR (A / P) * P */
1097 /* TODO: MOD(x, 0) */
1100 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1111 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1113 switch (expr->ts.type)
1116 /* Integer case is easy, we've got a builtin op. */
1117 type = TREE_TYPE (args[0]);
1120 se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1122 se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1127 /* Check if we have a builtin fmod. */
1128 switch (expr->ts.kind)
1147 /* Use it if it exists. */
1148 if (n != END_BUILTINS)
1150 tmp = build_addr (built_in_decls[n], current_function_decl);
1151 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1157 type = TREE_TYPE (args[0]);
1159 args[0] = gfc_evaluate_now (args[0], &se->pre);
1160 args[1] = gfc_evaluate_now (args[1], &se->pre);
1163 modulo = arg - floor (arg/arg2) * arg2, so
1164 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1166 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1167 thereby avoiding another division and retaining the accuracy
1168 of the builtin function. */
1169 if (n != END_BUILTINS && modulo)
1171 tree zero = gfc_build_const (type, integer_zero_node);
1172 tmp = gfc_evaluate_now (se->expr, &se->pre);
1173 test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1174 test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1175 test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1176 test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1177 test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1178 test = gfc_evaluate_now (test, &se->pre);
1179 se->expr = fold_build3 (COND_EXPR, type, test,
1180 fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1185 /* If we do not have a built_in fmod, the calculation is going to
1186 have to be done longhand. */
1187 tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1189 /* Test if the value is too large to handle sensibly. */
1190 gfc_set_model_kind (expr->ts.kind);
1192 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1193 ikind = expr->ts.kind;
1196 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1197 ikind = gfc_max_integer_kind;
1199 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1200 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1201 test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1203 mpfr_neg (huge, huge, GFC_RND_MODE);
1204 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1205 test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1206 test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1208 itype = gfc_get_int_type (ikind);
1210 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1212 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1213 tmp = convert (type, tmp);
1214 tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1215 tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1216 se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1225 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1228 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1236 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1237 type = TREE_TYPE (args[0]);
1239 val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1240 val = gfc_evaluate_now (val, &se->pre);
1242 zero = gfc_build_const (type, integer_zero_node);
1243 tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1244 se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1248 /* SIGN(A, B) is absolute value of A times sign of B.
1249 The real value versions use library functions to ensure the correct
1250 handling of negative zero. Integer case implemented as:
1251 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1255 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1261 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1262 if (expr->ts.type == BT_REAL)
1264 switch (expr->ts.kind)
1267 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1270 tmp = built_in_decls[BUILT_IN_COPYSIGN];
1274 tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1279 se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1283 /* Having excluded floating point types, we know we are now dealing
1284 with signed integer types. */
1285 type = TREE_TYPE (args[0]);
1287 /* Args[0] is used multiple times below. */
1288 args[0] = gfc_evaluate_now (args[0], &se->pre);
1290 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1291 the signs of A and B are the same, and of all ones if they differ. */
1292 tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1293 tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1294 build_int_cst (type, TYPE_PRECISION (type) - 1));
1295 tmp = gfc_evaluate_now (tmp, &se->pre);
1297 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1298 is all ones (i.e. -1). */
1299 se->expr = fold_build2 (BIT_XOR_EXPR, type,
1300 fold_build2 (PLUS_EXPR, type, args[0], tmp),
1305 /* Test for the presence of an optional argument. */
1308 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1312 arg = expr->value.function.actual->expr;
1313 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1314 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1315 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1319 /* Calculate the double precision product of two single precision values. */
1322 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1327 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1329 /* Convert the args to double precision before multiplying. */
1330 type = gfc_typenode_for_spec (&expr->ts);
1331 args[0] = convert (type, args[0]);
1332 args[1] = convert (type, args[1]);
1333 se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1337 /* Return a length one character string containing an ascii character. */
1340 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1345 unsigned int num_args;
1347 num_args = gfc_intrinsic_argument_list_length (expr);
1348 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1350 type = gfc_get_char_type (expr->ts.kind);
1351 var = gfc_create_var (type, "char");
1353 arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1354 gfc_add_modify (&se->pre, var, arg[0]);
1355 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1356 se->string_length = integer_one_node;
1361 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1369 unsigned int num_args;
1371 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1372 args = (tree *) alloca (sizeof (tree) * num_args);
1374 var = gfc_create_var (pchar_type_node, "pstr");
1375 len = gfc_create_var (gfc_get_int_type (8), "len");
1377 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1378 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1379 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1381 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1382 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1383 fndecl, num_args, args);
1384 gfc_add_expr_to_block (&se->pre, tmp);
1386 /* Free the temporary afterwards, if necessary. */
1387 cond = fold_build2 (GT_EXPR, boolean_type_node,
1388 len, build_int_cst (TREE_TYPE (len), 0));
1389 tmp = gfc_call_free (var);
1390 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1391 gfc_add_expr_to_block (&se->post, tmp);
1394 se->string_length = len;
1399 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1407 unsigned int num_args;
1409 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1410 args = (tree *) alloca (sizeof (tree) * num_args);
1412 var = gfc_create_var (pchar_type_node, "pstr");
1413 len = gfc_create_var (gfc_get_int_type (4), "len");
1415 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1416 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1417 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1419 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1420 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1421 fndecl, num_args, args);
1422 gfc_add_expr_to_block (&se->pre, tmp);
1424 /* Free the temporary afterwards, if necessary. */
1425 cond = fold_build2 (GT_EXPR, boolean_type_node,
1426 len, build_int_cst (TREE_TYPE (len), 0));
1427 tmp = gfc_call_free (var);
1428 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1429 gfc_add_expr_to_block (&se->post, tmp);
1432 se->string_length = len;
1436 /* Return a character string containing the tty name. */
1439 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1447 unsigned int num_args;
1449 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1450 args = (tree *) alloca (sizeof (tree) * num_args);
1452 var = gfc_create_var (pchar_type_node, "pstr");
1453 len = gfc_create_var (gfc_get_int_type (4), "len");
1455 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1456 args[0] = gfc_build_addr_expr (NULL_TREE, var);
1457 args[1] = gfc_build_addr_expr (NULL_TREE, len);
1459 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1460 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1461 fndecl, num_args, args);
1462 gfc_add_expr_to_block (&se->pre, tmp);
1464 /* Free the temporary afterwards, if necessary. */
1465 cond = fold_build2 (GT_EXPR, boolean_type_node,
1466 len, build_int_cst (TREE_TYPE (len), 0));
1467 tmp = gfc_call_free (var);
1468 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1469 gfc_add_expr_to_block (&se->post, tmp);
1472 se->string_length = len;
1476 /* Get the minimum/maximum value of all the parameters.
1477 minmax (a1, a2, a3, ...)
1480 if (a2 .op. mvar || isnan(mvar))
1482 if (a3 .op. mvar || isnan(mvar))
1489 /* TODO: Mismatching types can occur when specific names are used.
1490 These should be handled during resolution. */
1492 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1500 gfc_actual_arglist *argexpr;
1501 unsigned int i, nargs;
1503 nargs = gfc_intrinsic_argument_list_length (expr);
1504 args = (tree *) alloca (sizeof (tree) * nargs);
1506 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1507 type = gfc_typenode_for_spec (&expr->ts);
1509 argexpr = expr->value.function.actual;
1510 if (TREE_TYPE (args[0]) != type)
1511 args[0] = convert (type, args[0]);
1512 /* Only evaluate the argument once. */
1513 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1514 args[0] = gfc_evaluate_now (args[0], &se->pre);
1516 mvar = gfc_create_var (type, "M");
1517 gfc_add_modify (&se->pre, mvar, args[0]);
1518 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1524 /* Handle absent optional arguments by ignoring the comparison. */
1525 if (argexpr->expr->expr_type == EXPR_VARIABLE
1526 && argexpr->expr->symtree->n.sym->attr.optional
1527 && TREE_CODE (val) == INDIRECT_REF)
1529 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1530 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1535 /* Only evaluate the argument once. */
1536 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1537 val = gfc_evaluate_now (val, &se->pre);
1540 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1542 tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1544 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1545 __builtin_isnan might be made dependent on that module being loaded,
1546 to help performance of programs that don't rely on IEEE semantics. */
1547 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1549 isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1550 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1551 fold_convert (boolean_type_node, isnan));
1553 tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
1555 if (cond != NULL_TREE)
1556 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1558 gfc_add_expr_to_block (&se->pre, tmp);
1559 argexpr = argexpr->next;
1565 /* Generate library calls for MIN and MAX intrinsics for character
1568 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1571 tree var, len, fndecl, tmp, cond, function;
1574 nargs = gfc_intrinsic_argument_list_length (expr);
1575 args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1576 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1578 /* Create the result variables. */
1579 len = gfc_create_var (gfc_charlen_type_node, "len");
1580 args[0] = gfc_build_addr_expr (NULL_TREE, len);
1581 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1582 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1583 args[2] = build_int_cst (NULL_TREE, op);
1584 args[3] = build_int_cst (NULL_TREE, nargs / 2);
1586 if (expr->ts.kind == 1)
1587 function = gfor_fndecl_string_minmax;
1588 else if (expr->ts.kind == 4)
1589 function = gfor_fndecl_string_minmax_char4;
1593 /* Make the function call. */
1594 fndecl = build_addr (function, current_function_decl);
1595 tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
1597 gfc_add_expr_to_block (&se->pre, tmp);
1599 /* Free the temporary afterwards, if necessary. */
1600 cond = fold_build2 (GT_EXPR, boolean_type_node,
1601 len, build_int_cst (TREE_TYPE (len), 0));
1602 tmp = gfc_call_free (var);
1603 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1604 gfc_add_expr_to_block (&se->post, tmp);
1607 se->string_length = len;
1611 /* Create a symbol node for this intrinsic. The symbol from the frontend
1612 has the generic name. */
1615 gfc_get_symbol_for_expr (gfc_expr * expr)
1619 /* TODO: Add symbols for intrinsic function to the global namespace. */
1620 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1621 sym = gfc_new_symbol (expr->value.function.name, NULL);
1624 sym->attr.external = 1;
1625 sym->attr.function = 1;
1626 sym->attr.always_explicit = 1;
1627 sym->attr.proc = PROC_INTRINSIC;
1628 sym->attr.flavor = FL_PROCEDURE;
1632 sym->attr.dimension = 1;
1633 sym->as = gfc_get_array_spec ();
1634 sym->as->type = AS_ASSUMED_SHAPE;
1635 sym->as->rank = expr->rank;
1638 /* TODO: proper argument lists for external intrinsics. */
1642 /* Generate a call to an external intrinsic function. */
1644 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1649 gcc_assert (!se->ss || se->ss->expr == expr);
1652 gcc_assert (expr->rank > 0);
1654 gcc_assert (expr->rank == 0);
1656 sym = gfc_get_symbol_for_expr (expr);
1658 /* Calls to libgfortran_matmul need to be appended special arguments,
1659 to be able to call the BLAS ?gemm functions if required and possible. */
1660 append_args = NULL_TREE;
1661 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1662 && sym->ts.type != BT_LOGICAL)
1664 tree cint = gfc_get_int_type (gfc_c_int_kind);
1666 if (gfc_option.flag_external_blas
1667 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1668 && (sym->ts.kind == gfc_default_real_kind
1669 || sym->ts.kind == gfc_default_double_kind))
1673 if (sym->ts.type == BT_REAL)
1675 if (sym->ts.kind == gfc_default_real_kind)
1676 gemm_fndecl = gfor_fndecl_sgemm;
1678 gemm_fndecl = gfor_fndecl_dgemm;
1682 if (sym->ts.kind == gfc_default_real_kind)
1683 gemm_fndecl = gfor_fndecl_cgemm;
1685 gemm_fndecl = gfor_fndecl_zgemm;
1688 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1689 append_args = gfc_chainon_list
1690 (append_args, build_int_cst
1691 (cint, gfc_option.blas_matmul_limit));
1692 append_args = gfc_chainon_list (append_args,
1693 gfc_build_addr_expr (NULL_TREE,
1698 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1699 append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1700 append_args = gfc_chainon_list (append_args, null_pointer_node);
1704 gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1708 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1728 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int 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 ());
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, build_empty_stmt ());
1868 gfc_add_block_to_block (&body, &arrayse.pre);
1869 gfc_add_expr_to_block (&body, tmp);
1870 gfc_add_block_to_block (&body, &arrayse.post);
1872 gfc_trans_scalarizing_loops (&loop, &body);
1874 gfc_add_block_to_block (&se->pre, &loop.pre);
1875 gfc_add_block_to_block (&se->pre, &loop.post);
1876 gfc_cleanup_loop (&loop);
1881 /* Inline implementation of the sum and product intrinsics. */
1883 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1891 gfc_actual_arglist *actual;
1896 gfc_expr *arrayexpr;
1901 gfc_conv_intrinsic_funcall (se, expr);
1905 type = gfc_typenode_for_spec (&expr->ts);
1906 /* Initialize the result. */
1907 resvar = gfc_create_var (type, "val");
1908 if (op == PLUS_EXPR)
1909 tmp = gfc_build_const (type, integer_zero_node);
1911 tmp = gfc_build_const (type, integer_one_node);
1913 gfc_add_modify (&se->pre, resvar, tmp);
1915 /* Walk the arguments. */
1916 actual = expr->value.function.actual;
1917 arrayexpr = actual->expr;
1918 arrayss = gfc_walk_expr (arrayexpr);
1919 gcc_assert (arrayss != gfc_ss_terminator);
1921 actual = actual->next->next;
1922 gcc_assert (actual);
1923 maskexpr = actual->expr;
1924 if (maskexpr && maskexpr->rank != 0)
1926 maskss = gfc_walk_expr (maskexpr);
1927 gcc_assert (maskss != gfc_ss_terminator);
1932 /* Initialize the scalarizer. */
1933 gfc_init_loopinfo (&loop);
1934 gfc_add_ss_to_loop (&loop, arrayss);
1936 gfc_add_ss_to_loop (&loop, maskss);
1938 /* Initialize the loop. */
1939 gfc_conv_ss_startstride (&loop);
1940 gfc_conv_loop_setup (&loop, &expr->where);
1942 gfc_mark_ss_chain_used (arrayss, 1);
1944 gfc_mark_ss_chain_used (maskss, 1);
1945 /* Generate the loop body. */
1946 gfc_start_scalarized_body (&loop, &body);
1948 /* If we have a mask, only add this element if the mask is set. */
1951 gfc_init_se (&maskse, NULL);
1952 gfc_copy_loopinfo_to_se (&maskse, &loop);
1954 gfc_conv_expr_val (&maskse, maskexpr);
1955 gfc_add_block_to_block (&body, &maskse.pre);
1957 gfc_start_block (&block);
1960 gfc_init_block (&block);
1962 /* Do the actual summation/product. */
1963 gfc_init_se (&arrayse, NULL);
1964 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1965 arrayse.ss = arrayss;
1966 gfc_conv_expr_val (&arrayse, arrayexpr);
1967 gfc_add_block_to_block (&block, &arrayse.pre);
1969 tmp = fold_build2 (op, type, resvar, arrayse.expr);
1970 gfc_add_modify (&block, resvar, tmp);
1971 gfc_add_block_to_block (&block, &arrayse.post);
1975 /* We enclose the above in if (mask) {...} . */
1976 tmp = gfc_finish_block (&block);
1978 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1981 tmp = gfc_finish_block (&block);
1982 gfc_add_expr_to_block (&body, tmp);
1984 gfc_trans_scalarizing_loops (&loop, &body);
1986 /* For a scalar mask, enclose the loop in an if statement. */
1987 if (maskexpr && maskss == NULL)
1989 gfc_init_se (&maskse, NULL);
1990 gfc_conv_expr_val (&maskse, maskexpr);
1991 gfc_init_block (&block);
1992 gfc_add_block_to_block (&block, &loop.pre);
1993 gfc_add_block_to_block (&block, &loop.post);
1994 tmp = gfc_finish_block (&block);
1996 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1997 gfc_add_expr_to_block (&block, tmp);
1998 gfc_add_block_to_block (&se->pre, &block);
2002 gfc_add_block_to_block (&se->pre, &loop.pre);
2003 gfc_add_block_to_block (&se->pre, &loop.post);
2006 gfc_cleanup_loop (&loop);
2012 /* Inline implementation of the dot_product intrinsic. This function
2013 is based on gfc_conv_intrinsic_arith (the previous function). */
2015 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2023 gfc_actual_arglist *actual;
2024 gfc_ss *arrayss1, *arrayss2;
2025 gfc_se arrayse1, arrayse2;
2026 gfc_expr *arrayexpr1, *arrayexpr2;
2028 type = gfc_typenode_for_spec (&expr->ts);
2030 /* Initialize the result. */
2031 resvar = gfc_create_var (type, "val");
2032 if (expr->ts.type == BT_LOGICAL)
2033 tmp = build_int_cst (type, 0);
2035 tmp = gfc_build_const (type, integer_zero_node);
2037 gfc_add_modify (&se->pre, resvar, tmp);
2039 /* Walk argument #1. */
2040 actual = expr->value.function.actual;
2041 arrayexpr1 = actual->expr;
2042 arrayss1 = gfc_walk_expr (arrayexpr1);
2043 gcc_assert (arrayss1 != gfc_ss_terminator);
2045 /* Walk argument #2. */
2046 actual = actual->next;
2047 arrayexpr2 = actual->expr;
2048 arrayss2 = gfc_walk_expr (arrayexpr2);
2049 gcc_assert (arrayss2 != gfc_ss_terminator);
2051 /* Initialize the scalarizer. */
2052 gfc_init_loopinfo (&loop);
2053 gfc_add_ss_to_loop (&loop, arrayss1);
2054 gfc_add_ss_to_loop (&loop, arrayss2);
2056 /* Initialize the loop. */
2057 gfc_conv_ss_startstride (&loop);
2058 gfc_conv_loop_setup (&loop, &expr->where);
2060 gfc_mark_ss_chain_used (arrayss1, 1);
2061 gfc_mark_ss_chain_used (arrayss2, 1);
2063 /* Generate the loop body. */
2064 gfc_start_scalarized_body (&loop, &body);
2065 gfc_init_block (&block);
2067 /* Make the tree expression for [conjg(]array1[)]. */
2068 gfc_init_se (&arrayse1, NULL);
2069 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2070 arrayse1.ss = arrayss1;
2071 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2072 if (expr->ts.type == BT_COMPLEX)
2073 arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2074 gfc_add_block_to_block (&block, &arrayse1.pre);
2076 /* Make the tree expression for array2. */
2077 gfc_init_se (&arrayse2, NULL);
2078 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2079 arrayse2.ss = arrayss2;
2080 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2081 gfc_add_block_to_block (&block, &arrayse2.pre);
2083 /* Do the actual product and sum. */
2084 if (expr->ts.type == BT_LOGICAL)
2086 tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2087 tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2091 tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2092 tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2094 gfc_add_modify (&block, resvar, tmp);
2096 /* Finish up the loop block and the loop. */
2097 tmp = gfc_finish_block (&block);
2098 gfc_add_expr_to_block (&body, tmp);
2100 gfc_trans_scalarizing_loops (&loop, &body);
2101 gfc_add_block_to_block (&se->pre, &loop.pre);
2102 gfc_add_block_to_block (&se->pre, &loop.post);
2103 gfc_cleanup_loop (&loop);
2110 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2114 stmtblock_t ifblock;
2115 stmtblock_t elseblock;
2123 gfc_actual_arglist *actual;
2128 gfc_expr *arrayexpr;
2135 gfc_conv_intrinsic_funcall (se, expr);
2139 /* Initialize the result. */
2140 pos = gfc_create_var (gfc_array_index_type, "pos");
2141 offset = gfc_create_var (gfc_array_index_type, "offset");
2142 type = gfc_typenode_for_spec (&expr->ts);
2144 /* Walk the arguments. */
2145 actual = expr->value.function.actual;
2146 arrayexpr = actual->expr;
2147 arrayss = gfc_walk_expr (arrayexpr);
2148 gcc_assert (arrayss != gfc_ss_terminator);
2150 actual = actual->next->next;
2151 gcc_assert (actual);
2152 maskexpr = actual->expr;
2153 if (maskexpr && maskexpr->rank != 0)
2155 maskss = gfc_walk_expr (maskexpr);
2156 gcc_assert (maskss != gfc_ss_terminator);
2161 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2162 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2163 switch (arrayexpr->ts.type)
2166 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2167 arrayexpr->ts.kind, 0);
2171 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2172 arrayexpr->ts.kind);
2179 /* We start with the most negative possible value for MAXLOC, and the most
2180 positive possible value for MINLOC. The most negative possible value is
2181 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2182 possible value is HUGE in both cases. */
2184 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2185 gfc_add_modify (&se->pre, limit, tmp);
2187 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2188 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2189 build_int_cst (type, 1));
2191 /* Initialize the scalarizer. */
2192 gfc_init_loopinfo (&loop);
2193 gfc_add_ss_to_loop (&loop, arrayss);
2195 gfc_add_ss_to_loop (&loop, maskss);
2197 /* Initialize the loop. */
2198 gfc_conv_ss_startstride (&loop);
2199 gfc_conv_loop_setup (&loop, &expr->where);
2201 gcc_assert (loop.dimen == 1);
2203 /* Initialize the position to zero, following Fortran 2003. We are free
2204 to do this because Fortran 95 allows the result of an entirely false
2205 mask to be processor dependent. */
2206 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2208 gfc_mark_ss_chain_used (arrayss, 1);
2210 gfc_mark_ss_chain_used (maskss, 1);
2211 /* Generate the loop body. */
2212 gfc_start_scalarized_body (&loop, &body);
2214 /* If we have a mask, only check this element if the mask is set. */
2217 gfc_init_se (&maskse, NULL);
2218 gfc_copy_loopinfo_to_se (&maskse, &loop);
2220 gfc_conv_expr_val (&maskse, maskexpr);
2221 gfc_add_block_to_block (&body, &maskse.pre);
2223 gfc_start_block (&block);
2226 gfc_init_block (&block);
2228 /* Compare with the current limit. */
2229 gfc_init_se (&arrayse, NULL);
2230 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2231 arrayse.ss = arrayss;
2232 gfc_conv_expr_val (&arrayse, arrayexpr);
2233 gfc_add_block_to_block (&block, &arrayse.pre);
2235 /* We do the following if this is a more extreme value. */
2236 gfc_start_block (&ifblock);
2238 /* Assign the value to the limit... */
2239 gfc_add_modify (&ifblock, limit, arrayse.expr);
2241 /* Remember where we are. An offset must be added to the loop
2242 counter to obtain the required position. */
2244 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2245 gfc_index_one_node, loop.from[0]);
2247 tmp = gfc_index_one_node;
2249 gfc_add_modify (&block, offset, tmp);
2251 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2252 loop.loopvar[0], offset);
2253 gfc_add_modify (&ifblock, pos, tmp);
2255 ifbody = gfc_finish_block (&ifblock);
2257 /* If it is a more extreme value or pos is still zero and the value
2258 equal to the limit. */
2259 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2260 fold_build2 (EQ_EXPR, boolean_type_node,
2261 pos, gfc_index_zero_node),
2262 fold_build2 (EQ_EXPR, boolean_type_node,
2263 arrayse.expr, limit));
2264 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2265 fold_build2 (op, boolean_type_node,
2266 arrayse.expr, limit), tmp);
2267 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2268 gfc_add_expr_to_block (&block, tmp);
2272 /* We enclose the above in if (mask) {...}. */
2273 tmp = gfc_finish_block (&block);
2275 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2278 tmp = gfc_finish_block (&block);
2279 gfc_add_expr_to_block (&body, tmp);
2281 gfc_trans_scalarizing_loops (&loop, &body);
2283 /* For a scalar mask, enclose the loop in an if statement. */
2284 if (maskexpr && maskss == NULL)
2286 gfc_init_se (&maskse, NULL);
2287 gfc_conv_expr_val (&maskse, maskexpr);
2288 gfc_init_block (&block);
2289 gfc_add_block_to_block (&block, &loop.pre);
2290 gfc_add_block_to_block (&block, &loop.post);
2291 tmp = gfc_finish_block (&block);
2293 /* For the else part of the scalar mask, just initialize
2294 the pos variable the same way as above. */
2296 gfc_init_block (&elseblock);
2297 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2298 elsetmp = gfc_finish_block (&elseblock);
2300 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2301 gfc_add_expr_to_block (&block, tmp);
2302 gfc_add_block_to_block (&se->pre, &block);
2306 gfc_add_block_to_block (&se->pre, &loop.pre);
2307 gfc_add_block_to_block (&se->pre, &loop.post);
2309 gfc_cleanup_loop (&loop);
2311 se->expr = convert (type, pos);
2315 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2324 gfc_actual_arglist *actual;
2329 gfc_expr *arrayexpr;
2335 gfc_conv_intrinsic_funcall (se, expr);
2339 type = gfc_typenode_for_spec (&expr->ts);
2340 /* Initialize the result. */
2341 limit = gfc_create_var (type, "limit");
2342 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2343 switch (expr->ts.type)
2346 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind, 0);
2350 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2357 /* We start with the most negative possible value for MAXVAL, and the most
2358 positive possible value for MINVAL. The most negative possible value is
2359 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2360 possible value is HUGE in both cases. */
2362 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2364 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2365 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2366 tmp, build_int_cst (type, 1));
2368 gfc_add_modify (&se->pre, limit, tmp);
2370 /* Walk the arguments. */
2371 actual = expr->value.function.actual;
2372 arrayexpr = actual->expr;
2373 arrayss = gfc_walk_expr (arrayexpr);
2374 gcc_assert (arrayss != gfc_ss_terminator);
2376 actual = actual->next->next;
2377 gcc_assert (actual);
2378 maskexpr = actual->expr;
2379 if (maskexpr && maskexpr->rank != 0)
2381 maskss = gfc_walk_expr (maskexpr);
2382 gcc_assert (maskss != gfc_ss_terminator);
2387 /* Initialize the scalarizer. */
2388 gfc_init_loopinfo (&loop);
2389 gfc_add_ss_to_loop (&loop, arrayss);
2391 gfc_add_ss_to_loop (&loop, maskss);
2393 /* Initialize the loop. */
2394 gfc_conv_ss_startstride (&loop);
2395 gfc_conv_loop_setup (&loop, &expr->where);
2397 gfc_mark_ss_chain_used (arrayss, 1);
2399 gfc_mark_ss_chain_used (maskss, 1);
2400 /* Generate the loop body. */
2401 gfc_start_scalarized_body (&loop, &body);
2403 /* If we have a mask, only add this element if the mask is set. */
2406 gfc_init_se (&maskse, NULL);
2407 gfc_copy_loopinfo_to_se (&maskse, &loop);
2409 gfc_conv_expr_val (&maskse, maskexpr);
2410 gfc_add_block_to_block (&body, &maskse.pre);
2412 gfc_start_block (&block);
2415 gfc_init_block (&block);
2417 /* Compare with the current limit. */
2418 gfc_init_se (&arrayse, NULL);
2419 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2420 arrayse.ss = arrayss;
2421 gfc_conv_expr_val (&arrayse, arrayexpr);
2422 gfc_add_block_to_block (&block, &arrayse.pre);
2424 /* Assign the value to the limit... */
2425 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2427 /* If it is a more extreme value. */
2428 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2429 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2430 gfc_add_expr_to_block (&block, tmp);
2431 gfc_add_block_to_block (&block, &arrayse.post);
2433 tmp = gfc_finish_block (&block);
2435 /* We enclose the above in if (mask) {...}. */
2436 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2437 gfc_add_expr_to_block (&body, tmp);
2439 gfc_trans_scalarizing_loops (&loop, &body);
2441 /* For a scalar mask, enclose the loop in an if statement. */
2442 if (maskexpr && maskss == NULL)
2444 gfc_init_se (&maskse, NULL);
2445 gfc_conv_expr_val (&maskse, maskexpr);
2446 gfc_init_block (&block);
2447 gfc_add_block_to_block (&block, &loop.pre);
2448 gfc_add_block_to_block (&block, &loop.post);
2449 tmp = gfc_finish_block (&block);
2451 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2452 gfc_add_expr_to_block (&block, tmp);
2453 gfc_add_block_to_block (&se->pre, &block);
2457 gfc_add_block_to_block (&se->pre, &loop.pre);
2458 gfc_add_block_to_block (&se->pre, &loop.post);
2461 gfc_cleanup_loop (&loop);
2466 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2468 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2474 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2475 type = TREE_TYPE (args[0]);
2477 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2478 tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2479 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2480 build_int_cst (type, 0));
2481 type = gfc_typenode_for_spec (&expr->ts);
2482 se->expr = convert (type, tmp);
2485 /* Generate code to perform the specified operation. */
2487 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2491 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2492 se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2497 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2501 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2502 se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2505 /* Set or clear a single bit. */
2507 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2514 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2515 type = TREE_TYPE (args[0]);
2517 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2523 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2525 se->expr = fold_build2 (op, type, args[0], tmp);
2528 /* Extract a sequence of bits.
2529 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2531 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2538 gfc_conv_intrinsic_function_args (se, expr, args, 3);
2539 type = TREE_TYPE (args[0]);
2541 mask = build_int_cst (type, -1);
2542 mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
2543 mask = fold_build1 (BIT_NOT_EXPR, type, mask);
2545 tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
2547 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2550 /* RSHIFT (I, SHIFT) = I >> SHIFT
2551 LSHIFT (I, SHIFT) = I << SHIFT */
2553 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2557 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2559 se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2560 TREE_TYPE (args[0]), args[0], args[1]);
2563 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2565 : ((shift >= 0) ? i << shift : i >> -shift)
2566 where all shifts are logical shifts. */
2568 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2580 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2581 type = TREE_TYPE (args[0]);
2582 utype = unsigned_type_for (type);
2584 width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2586 /* Left shift if positive. */
2587 lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2589 /* Right shift if negative.
2590 We convert to an unsigned type because we want a logical shift.
2591 The standard doesn't define the case of shifting negative
2592 numbers, and we try to be compatible with other compilers, most
2593 notably g77, here. */
2594 rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
2595 convert (utype, args[0]), width));
2597 tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2598 build_int_cst (TREE_TYPE (args[1]), 0));
2599 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2601 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2602 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2604 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
2605 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2607 se->expr = fold_build3 (COND_EXPR, type, cond,
2608 build_int_cst (type, 0), tmp);
2612 /* Circular shift. AKA rotate or barrel shift. */
2615 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2623 unsigned int num_args;
2625 num_args = gfc_intrinsic_argument_list_length (expr);
2626 args = (tree *) alloca (sizeof (tree) * num_args);
2628 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2632 /* Use a library function for the 3 parameter version. */
2633 tree int4type = gfc_get_int_type (4);
2635 type = TREE_TYPE (args[0]);
2636 /* We convert the first argument to at least 4 bytes, and
2637 convert back afterwards. This removes the need for library
2638 functions for all argument sizes, and function will be
2639 aligned to at least 32 bits, so there's no loss. */
2640 if (expr->ts.kind < 4)
2641 args[0] = convert (int4type, args[0]);
2643 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2644 need loads of library functions. They cannot have values >
2645 BIT_SIZE (I) so the conversion is safe. */
2646 args[1] = convert (int4type, args[1]);
2647 args[2] = convert (int4type, args[2]);
2649 switch (expr->ts.kind)
2654 tmp = gfor_fndecl_math_ishftc4;
2657 tmp = gfor_fndecl_math_ishftc8;
2660 tmp = gfor_fndecl_math_ishftc16;
2665 se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2666 /* Convert the result back to the original type, if we extended
2667 the first argument's width above. */
2668 if (expr->ts.kind < 4)
2669 se->expr = convert (type, se->expr);
2673 type = TREE_TYPE (args[0]);
2675 /* Rotate left if positive. */
2676 lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2678 /* Rotate right if negative. */
2679 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2680 rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2682 zero = build_int_cst (TREE_TYPE (args[1]), 0);
2683 tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2684 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2686 /* Do nothing if shift == 0. */
2687 tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2688 se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2691 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
2692 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
2694 The conditional expression is necessary because the result of LEADZ(0)
2695 is defined, but the result of __builtin_clz(0) is undefined for most
2698 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
2699 difference in bit size between the argument of LEADZ and the C int. */
2702 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
2714 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2716 /* Which variant of __builtin_clz* should we call? */
2717 arg_kind = expr->value.function.actual->expr->ts.kind;
2718 i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
2724 arg_type = unsigned_type_node;
2729 arg_type = long_unsigned_type_node;
2734 arg_type = long_long_unsigned_type_node;
2742 /* Convert the actual argument to the proper argument type for the built-in
2743 function. But the return type is of the default INTEGER kind. */
2744 arg = fold_convert (arg_type, arg);
2745 result_type = gfc_get_int_type (gfc_default_integer_kind);
2747 /* Compute LEADZ for the case i .ne. 0. */
2748 s = TYPE_PRECISION (arg_type) - gfc_integer_kinds[i].bit_size;
2749 tmp = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
2750 leadz = fold_build2 (MINUS_EXPR, result_type,
2751 tmp, build_int_cst (result_type, s));
2753 /* Build BIT_SIZE. */
2754 bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
2756 /* ??? For some combinations of targets and integer kinds, the condition
2757 can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used. Later. */
2758 cond = fold_build2 (EQ_EXPR, boolean_type_node,
2759 arg, build_int_cst (arg_type, 0));
2760 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
2763 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
2765 The conditional expression is necessary because the result of TRAILZ(0)
2766 is defined, but the result of __builtin_ctz(0) is undefined for most
2770 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
2781 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2783 /* Which variant of __builtin_clz* should we call? */
2784 arg_kind = expr->value.function.actual->expr->ts.kind;
2785 i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
2786 switch (expr->ts.kind)
2791 arg_type = unsigned_type_node;
2796 arg_type = long_unsigned_type_node;
2801 arg_type = long_long_unsigned_type_node;
2809 /* Convert the actual argument to the proper argument type for the built-in
2810 function. But the return type is of the default INTEGER kind. */
2811 arg = fold_convert (arg_type, arg);
2812 result_type = gfc_get_int_type (gfc_default_integer_kind);
2814 /* Compute TRAILZ for the case i .ne. 0. */
2815 trailz = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
2817 /* Build BIT_SIZE. */
2818 bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
2820 /* ??? For some combinations of targets and integer kinds, the condition
2821 can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used. Later. */
2822 cond = fold_build2 (EQ_EXPR, boolean_type_node,
2823 arg, build_int_cst (arg_type, 0));
2824 se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
2827 /* Process an intrinsic with unspecified argument-types that has an optional
2828 argument (which could be of type character), e.g. EOSHIFT. For those, we
2829 need to append the string length of the optional argument if it is not
2830 present and the type is really character.
2831 primary specifies the position (starting at 1) of the non-optional argument
2832 specifying the type and optional gives the position of the optional
2833 argument in the arglist. */
2836 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
2837 unsigned primary, unsigned optional)
2839 gfc_actual_arglist* prim_arg;
2840 gfc_actual_arglist* opt_arg;
2842 gfc_actual_arglist* arg;
2846 /* Find the two arguments given as position. */
2850 for (arg = expr->value.function.actual; arg; arg = arg->next)
2854 if (cur_pos == primary)
2856 if (cur_pos == optional)
2859 if (cur_pos >= primary && cur_pos >= optional)
2862 gcc_assert (prim_arg);
2863 gcc_assert (prim_arg->expr);
2864 gcc_assert (opt_arg);
2866 /* If we do have type CHARACTER and the optional argument is really absent,
2867 append a dummy 0 as string length. */
2868 append_args = NULL_TREE;
2869 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
2873 dummy = build_int_cst (gfc_charlen_type_node, 0);
2874 append_args = gfc_chainon_list (append_args, dummy);
2877 /* Build the call itself. */
2878 sym = gfc_get_symbol_for_expr (expr);
2879 gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
2884 /* The length of a character string. */
2886 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2896 gcc_assert (!se->ss);
2898 arg = expr->value.function.actual->expr;
2900 type = gfc_typenode_for_spec (&expr->ts);
2901 switch (arg->expr_type)
2904 len = build_int_cst (NULL_TREE, arg->value.character.length);
2908 /* Obtain the string length from the function used by
2909 trans-array.c(gfc_trans_array_constructor). */
2911 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2915 if (arg->ref == NULL
2916 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2918 /* This doesn't catch all cases.
2919 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2920 and the surrounding thread. */
2921 sym = arg->symtree->n.sym;
2922 decl = gfc_get_symbol_decl (sym);
2923 if (decl == current_function_decl && sym->attr.function
2924 && (sym->result == sym))
2925 decl = gfc_get_fake_result_decl (sym, 0);
2927 len = sym->ts.cl->backend_decl;
2932 /* Otherwise fall through. */
2935 /* Anybody stupid enough to do this deserves inefficient code. */
2936 ss = gfc_walk_expr (arg);
2937 gfc_init_se (&argse, se);
2938 if (ss == gfc_ss_terminator)
2939 gfc_conv_expr (&argse, arg);
2941 gfc_conv_expr_descriptor (&argse, arg, ss);
2942 gfc_add_block_to_block (&se->pre, &argse.pre);
2943 gfc_add_block_to_block (&se->post, &argse.post);
2944 len = argse.string_length;
2947 se->expr = convert (type, len);
2950 /* The length of a character string not including trailing blanks. */
2952 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2954 int kind = expr->value.function.actual->expr->ts.kind;
2955 tree args[2], type, fndecl;
2957 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2958 type = gfc_typenode_for_spec (&expr->ts);
2961 fndecl = gfor_fndecl_string_len_trim;
2963 fndecl = gfor_fndecl_string_len_trim_char4;
2967 se->expr = build_call_expr (fndecl, 2, args[0], args[1]);
2968 se->expr = convert (type, se->expr);
2972 /* Returns the starting position of a substring within a string. */
2975 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
2978 tree logical4_type_node = gfc_get_logical_type (4);
2982 unsigned int num_args;
2984 args = (tree *) alloca (sizeof (tree) * 5);
2986 /* Get number of arguments; characters count double due to the
2987 string length argument. Kind= is not passed to the library
2988 and thus ignored. */
2989 if (expr->value.function.actual->next->next->expr == NULL)
2994 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2995 type = gfc_typenode_for_spec (&expr->ts);
2998 args[4] = build_int_cst (logical4_type_node, 0);
3000 args[4] = convert (logical4_type_node, args[4]);
3002 fndecl = build_addr (function, current_function_decl);
3003 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
3005 se->expr = convert (type, se->expr);
3009 /* The ascii value for a single character. */
3011 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3013 tree args[2], type, pchartype;
3015 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3016 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3017 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3018 args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3019 type = gfc_typenode_for_spec (&expr->ts);
3021 se->expr = build_fold_indirect_ref (args[1]);
3022 se->expr = convert (type, se->expr);
3026 /* Intrinsic ISNAN calls __builtin_isnan. */
3029 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3033 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3034 se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
3035 STRIP_TYPE_NOPS (se->expr);
3036 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3040 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3041 their argument against a constant integer value. */
3044 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3048 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3049 se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3050 arg, build_int_cst (TREE_TYPE (arg), value));
3055 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
3058 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3066 unsigned int num_args;
3068 num_args = gfc_intrinsic_argument_list_length (expr);
3069 args = (tree *) alloca (sizeof (tree) * num_args);
3071 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3072 if (expr->ts.type != BT_CHARACTER)
3080 /* We do the same as in the non-character case, but the argument
3081 list is different because of the string length arguments. We
3082 also have to set the string length for the result. */
3089 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3091 se->string_length = len;
3093 type = TREE_TYPE (tsource);
3094 se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3095 fold_convert (type, fsource));
3099 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
3101 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3103 tree arg, type, tmp;
3106 switch (expr->ts.kind)
3109 frexp = BUILT_IN_FREXPF;
3112 frexp = BUILT_IN_FREXP;
3116 frexp = BUILT_IN_FREXPL;
3122 type = gfc_typenode_for_spec (&expr->ts);
3123 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3124 tmp = gfc_create_var (integer_type_node, NULL);
3125 se->expr = build_call_expr (built_in_decls[frexp], 2,
3126 fold_convert (type, arg),
3127 gfc_build_addr_expr (NULL_TREE, tmp));
3128 se->expr = fold_convert (type, se->expr);
3132 /* NEAREST (s, dir) is translated into
3133 tmp = copysign (INF, dir);
3134 return nextafter (s, tmp);
3137 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3139 tree args[2], type, tmp;
3140 int nextafter, copysign, inf;
3142 switch (expr->ts.kind)
3145 nextafter = BUILT_IN_NEXTAFTERF;
3146 copysign = BUILT_IN_COPYSIGNF;
3147 inf = BUILT_IN_INFF;
3150 nextafter = BUILT_IN_NEXTAFTER;
3151 copysign = BUILT_IN_COPYSIGN;
3156 nextafter = BUILT_IN_NEXTAFTERL;
3157 copysign = BUILT_IN_COPYSIGNL;
3158 inf = BUILT_IN_INFL;
3164 type = gfc_typenode_for_spec (&expr->ts);
3165 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3166 tmp = build_call_expr (built_in_decls[copysign], 2,
3167 build_call_expr (built_in_decls[inf], 0),
3168 fold_convert (type, args[1]));
3169 se->expr = build_call_expr (built_in_decls[nextafter], 2,
3170 fold_convert (type, args[0]), tmp);
3171 se->expr = fold_convert (type, se->expr);
3175 /* SPACING (s) is translated into
3183 e = MAX_EXPR (e, emin);
3184 res = scalbn (1., e);
3188 where prec is the precision of s, gfc_real_kinds[k].digits,
3189 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3190 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
3193 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3195 tree arg, type, prec, emin, tiny, res, e;
3197 int frexp, scalbn, k;
3200 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3201 prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3202 emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3203 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3205 switch (expr->ts.kind)
3208 frexp = BUILT_IN_FREXPF;
3209 scalbn = BUILT_IN_SCALBNF;
3212 frexp = BUILT_IN_FREXP;
3213 scalbn = BUILT_IN_SCALBN;
3217 frexp = BUILT_IN_FREXPL;
3218 scalbn = BUILT_IN_SCALBNL;
3224 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3225 arg = gfc_evaluate_now (arg, &se->pre);
3227 type = gfc_typenode_for_spec (&expr->ts);
3228 e = gfc_create_var (integer_type_node, NULL);
3229 res = gfc_create_var (type, NULL);
3232 /* Build the block for s /= 0. */
3233 gfc_start_block (&block);
3234 tmp = build_call_expr (built_in_decls[frexp], 2, arg,
3235 gfc_build_addr_expr (NULL_TREE, e));
3236 gfc_add_expr_to_block (&block, tmp);
3238 tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3239 gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3242 tmp = build_call_expr (built_in_decls[scalbn], 2,
3243 build_real_from_int_cst (type, integer_one_node), e);
3244 gfc_add_modify (&block, res, tmp);
3246 /* Finish by building the IF statement. */
3247 cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3248 build_real_from_int_cst (type, integer_zero_node));
3249 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3250 gfc_finish_block (&block));
3252 gfc_add_expr_to_block (&se->pre, tmp);
3257 /* RRSPACING (s) is translated into
3264 x = scalbn (x, precision - e);
3268 where precision is gfc_real_kinds[k].digits. */
3271 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3273 tree arg, type, e, x, cond, stmt, tmp;
3274 int frexp, scalbn, fabs, prec, k;
3277 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3278 prec = gfc_real_kinds[k].digits;
3279 switch (expr->ts.kind)
3282 frexp = BUILT_IN_FREXPF;
3283 scalbn = BUILT_IN_SCALBNF;
3284 fabs = BUILT_IN_FABSF;
3287 frexp = BUILT_IN_FREXP;
3288 scalbn = BUILT_IN_SCALBN;
3289 fabs = BUILT_IN_FABS;
3293 frexp = BUILT_IN_FREXPL;
3294 scalbn = BUILT_IN_SCALBNL;
3295 fabs = BUILT_IN_FABSL;
3301 type = gfc_typenode_for_spec (&expr->ts);
3302 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3303 arg = gfc_evaluate_now (arg, &se->pre);
3305 e = gfc_create_var (integer_type_node, NULL);
3306 x = gfc_create_var (type, NULL);
3307 gfc_add_modify (&se->pre, x,
3308 build_call_expr (built_in_decls[fabs], 1, arg));
3311 gfc_start_block (&block);
3312 tmp = build_call_expr (built_in_decls[frexp], 2, arg,
3313 gfc_build_addr_expr (NULL_TREE, e));
3314 gfc_add_expr_to_block (&block, tmp);
3316 tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3317 build_int_cst (NULL_TREE, prec), e);
3318 tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp);
3319 gfc_add_modify (&block, x, tmp);
3320 stmt = gfc_finish_block (&block);
3322 cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3323 build_real_from_int_cst (type, integer_zero_node));
3324 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt ());
3325 gfc_add_expr_to_block (&se->pre, tmp);
3327 se->expr = fold_convert (type, x);
3331 /* SCALE (s, i) is translated into scalbn (s, i). */
3333 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3338 switch (expr->ts.kind)
3341 scalbn = BUILT_IN_SCALBNF;
3344 scalbn = BUILT_IN_SCALBN;
3348 scalbn = BUILT_IN_SCALBNL;
3354 type = gfc_typenode_for_spec (&expr->ts);
3355 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3356 se->expr = build_call_expr (built_in_decls[scalbn], 2,
3357 fold_convert (type, args[0]),
3358 fold_convert (integer_type_node, args[1]));
3359 se->expr = fold_convert (type, se->expr);
3363 /* SET_EXPONENT (s, i) is translated into
3364 scalbn (frexp (s, &dummy_int), i). */
3366 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3368 tree args[2], type, tmp;
3371 switch (expr->ts.kind)
3374 frexp = BUILT_IN_FREXPF;
3375 scalbn = BUILT_IN_SCALBNF;
3378 frexp = BUILT_IN_FREXP;
3379 scalbn = BUILT_IN_SCALBN;
3383 frexp = BUILT_IN_FREXPL;
3384 scalbn = BUILT_IN_SCALBNL;
3390 type = gfc_typenode_for_spec (&expr->ts);
3391 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3393 tmp = gfc_create_var (integer_type_node, NULL);
3394 tmp = build_call_expr (built_in_decls[frexp], 2,
3395 fold_convert (type, args[0]),
3396 gfc_build_addr_expr (NULL_TREE, tmp));
3397 se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp,
3398 fold_convert (integer_type_node, args[1]));
3399 se->expr = fold_convert (type, se->expr);
3404 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3406 gfc_actual_arglist *actual;
3414 gfc_init_se (&argse, NULL);
3415 actual = expr->value.function.actual;
3417 ss = gfc_walk_expr (actual->expr);
3418 gcc_assert (ss != gfc_ss_terminator);
3419 argse.want_pointer = 1;
3420 argse.data_not_needed = 1;
3421 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3422 gfc_add_block_to_block (&se->pre, &argse.pre);
3423 gfc_add_block_to_block (&se->post, &argse.post);
3424 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3426 /* Build the call to size0. */
3427 fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
3429 actual = actual->next;
3433 gfc_init_se (&argse, NULL);
3434 gfc_conv_expr_type (&argse, actual->expr,
3435 gfc_array_index_type);
3436 gfc_add_block_to_block (&se->pre, &argse.pre);
3438 /* Unusually, for an intrinsic, size does not exclude
3439 an optional arg2, so we must test for it. */
3440 if (actual->expr->expr_type == EXPR_VARIABLE
3441 && actual->expr->symtree->n.sym->attr.dummy
3442 && actual->expr->symtree->n.sym->attr.optional)
3445 /* Build the call to size1. */
3446 fncall1 = build_call_expr (gfor_fndecl_size1, 2,
3449 gfc_init_se (&argse, NULL);
3450 argse.want_pointer = 1;
3451 argse.data_not_needed = 1;
3452 gfc_conv_expr (&argse, actual->expr);
3453 gfc_add_block_to_block (&se->pre, &argse.pre);
3454 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3455 argse.expr, null_pointer_node);
3456 tmp = gfc_evaluate_now (tmp, &se->pre);
3457 se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3458 tmp, fncall1, fncall0);
3462 se->expr = NULL_TREE;
3463 argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3464 argse.expr, gfc_index_one_node);
3467 else if (expr->value.function.actual->expr->rank == 1)
3469 argse.expr = gfc_index_zero_node;
3470 se->expr = NULL_TREE;
3475 if (se->expr == NULL_TREE)
3477 tree ubound, lbound;
3479 arg1 = build_fold_indirect_ref (arg1);
3480 ubound = gfc_conv_descriptor_ubound (arg1, argse.expr);
3481 lbound = gfc_conv_descriptor_lbound (arg1, argse.expr);
3482 se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3484 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
3485 gfc_index_one_node);
3486 se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
3487 gfc_index_zero_node);
3490 type = gfc_typenode_for_spec (&expr->ts);
3491 se->expr = convert (type, se->expr);
3495 /* Helper function to compute the size of a character variable,
3496 excluding the terminating null characters. The result has
3497 gfc_array_index_type type. */
3500 size_of_string_in_bytes (int kind, tree string_length)
3503 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
3505 bytesize = build_int_cst (gfc_array_index_type,
3506 gfc_character_kinds[i].bit_size / 8);
3508 return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
3509 fold_convert (gfc_array_index_type, string_length));
3514 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
3527 arg = expr->value.function.actual->expr;
3529 gfc_init_se (&argse, NULL);
3530 ss = gfc_walk_expr (arg);
3532 if (ss == gfc_ss_terminator)
3534 gfc_conv_expr_reference (&argse, arg);
3535 source = argse.expr;
3537 type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3539 /* Obtain the source word length. */
3540 if (arg->ts.type == BT_CHARACTER)
3541 se->expr = size_of_string_in_bytes (arg->ts.kind,
3542 argse.string_length);
3544 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
3548 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
3549 argse.want_pointer = 0;
3550 gfc_conv_expr_descriptor (&argse, arg, ss);
3551 source = gfc_conv_descriptor_data_get (argse.expr);
3552 type = gfc_get_element_type (TREE_TYPE (argse.expr));
3554 /* Obtain the argument's word length. */
3555 if (arg->ts.type == BT_CHARACTER)
3556 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
3558 tmp = fold_convert (gfc_array_index_type,
3559 size_in_bytes (type));
3560 gfc_add_modify (&argse.pre, source_bytes, tmp);
3562 /* Obtain the size of the array in bytes. */
3563 for (n = 0; n < arg->rank; n++)
3566 idx = gfc_rank_cst[n];
3567 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3568 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3569 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3571 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3572 tmp, gfc_index_one_node);
3573 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3575 gfc_add_modify (&argse.pre, source_bytes, tmp);
3577 se->expr = source_bytes;
3580 gfc_add_block_to_block (&se->pre, &argse.pre);
3584 /* Intrinsic string comparison functions. */
3587 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
3591 gfc_conv_intrinsic_function_args (se, expr, args, 4);
3594 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
3595 expr->value.function.actual->expr->ts.kind);
3596 se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3597 build_int_cst (TREE_TYPE (se->expr), 0));
3600 /* Generate a call to the adjustl/adjustr library function. */
3602 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3610 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3613 type = TREE_TYPE (args[2]);
3614 var = gfc_conv_string_tmp (se, type, len);
3617 tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
3618 gfc_add_expr_to_block (&se->pre, tmp);
3620 se->string_length = len;
3624 /* Generate code for the TRANSFER intrinsic:
3626 DEST = TRANSFER (SOURCE, MOLD)
3628 typeof<DEST> = typeof<MOLD>
3633 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3635 typeof<DEST> = typeof<MOLD>
3637 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3638 sizeof (DEST(0) * SIZE). */
3640 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3657 gfc_actual_arglist *arg;
3667 info = &se->ss->data.info;
3669 /* Convert SOURCE. The output from this stage is:-
3670 source_bytes = length of the source in bytes
3671 source = pointer to the source data. */
3672 arg = expr->value.function.actual;
3674 /* Ensure double transfer through LOGICAL preserves all
3676 if (arg->expr->expr_type == EXPR_FUNCTION
3677 && arg->expr->value.function.esym == NULL
3678 && arg->expr->value.function.isym != NULL
3679 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
3680 && arg->expr->ts.type == BT_LOGICAL
3681 && expr->ts.type != arg->expr->ts.type)
3682 arg->expr->value.function.name = "__transfer_in_transfer";
3684 gfc_init_se (&argse, NULL);
3685 ss = gfc_walk_expr (arg->expr);
3687 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3689 /* Obtain the pointer to source and the length of source in bytes. */
3690 if (ss == gfc_ss_terminator)
3692 gfc_conv_expr_reference (&argse, arg->expr);
3693 source = argse.expr;
3695 source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3697 /* Obtain the source word length. */
3698 if (arg->expr->ts.type == BT_CHARACTER)
3699 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3700 argse.string_length);
3702 tmp = fold_convert (gfc_array_index_type,
3703 size_in_bytes (source_type));
3707 argse.want_pointer = 0;
3708 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3709 source = gfc_conv_descriptor_data_get (argse.expr);
3710 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3712 /* Repack the source if not a full variable array. */
3713 if (arg->expr->expr_type == EXPR_VARIABLE
3714 && arg->expr->ref->u.ar.type != AR_FULL)
3716 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
3718 if (gfc_option.warn_array_temp)
3719 gfc_warning ("Creating array temporary at %L", &expr->where);
3721 source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3722 source = gfc_evaluate_now (source, &argse.pre);
3724 /* Free the temporary. */
3725 gfc_start_block (&block);
3726 tmp = gfc_call_free (convert (pvoid_type_node, source));
3727 gfc_add_expr_to_block (&block, tmp);
3728 stmt = gfc_finish_block (&block);
3730 /* Clean up if it was repacked. */
3731 gfc_init_block (&block);
3732 tmp = gfc_conv_array_data (argse.expr);
3733 tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
3734 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3735 gfc_add_expr_to_block (&block, tmp);
3736 gfc_add_block_to_block (&block, &se->post);
3737 gfc_init_block (&se->post);
3738 gfc_add_block_to_block (&se->post, &block);
3741 /* Obtain the source word length. */
3742 if (arg->expr->ts.type == BT_CHARACTER)
3743 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3744 argse.string_length);
3746 tmp = fold_convert (gfc_array_index_type,
3747 size_in_bytes (source_type));
3749 /* Obtain the size of the array in bytes. */
3750 extent = gfc_create_var (gfc_array_index_type, NULL);
3751 for (n = 0; n < arg->expr->rank; n++)
3754 idx = gfc_rank_cst[n];
3755 gfc_add_modify (&argse.pre, source_bytes, tmp);
3756 stride = gfc_conv_descriptor_stride (argse.expr, idx);
3757 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3758 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3759 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3761 gfc_add_modify (&argse.pre, extent, tmp);
3762 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3763 extent, gfc_index_one_node);
3764 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3769 gfc_add_modify (&argse.pre, source_bytes, tmp);
3770 gfc_add_block_to_block (&se->pre, &argse.pre);
3771 gfc_add_block_to_block (&se->post, &argse.post);
3773 /* Now convert MOLD. The outputs are:
3774 mold_type = the TREE type of MOLD
3775 dest_word_len = destination word length in bytes. */
3778 gfc_init_se (&argse, NULL);
3779 ss = gfc_walk_expr (arg->expr);
3781 scalar_mold = arg->expr->rank == 0;
3783 if (ss == gfc_ss_terminator)
3785 gfc_conv_expr_reference (&argse, arg->expr);
3786 mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3790 gfc_init_se (&argse, NULL);
3791 argse.want_pointer = 0;
3792 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3793 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3796 gfc_add_block_to_block (&se->pre, &argse.pre);
3797 gfc_add_block_to_block (&se->post, &argse.post);
3799 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
3801 /* If this TRANSFER is nested in another TRANSFER, use a type
3802 that preserves all bits. */
3803 if (arg->expr->ts.type == BT_LOGICAL)
3804 mold_type = gfc_get_int_type (arg->expr->ts.kind);
3807 if (arg->expr->ts.type == BT_CHARACTER)
3809 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
3810 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3813 tmp = fold_convert (gfc_array_index_type,
3814 size_in_bytes (mold_type));
3816 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3817 gfc_add_modify (&se->pre, dest_word_len, tmp);
3819 /* Finally convert SIZE, if it is present. */
3821 size_words = gfc_create_var (gfc_array_index_type, NULL);
3825 gfc_init_se (&argse, NULL);
3826 gfc_conv_expr_reference (&argse, arg->expr);
3827 tmp = convert (gfc_array_index_type,
3828 build_fold_indirect_ref (argse.expr));
3829 gfc_add_block_to_block (&se->pre, &argse.pre);
3830 gfc_add_block_to_block (&se->post, &argse.post);
3835 /* Separate array and scalar results. */
3836 if (scalar_mold && tmp == NULL_TREE)
3837 goto scalar_transfer;
3839 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3840 if (tmp != NULL_TREE)
3841 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3842 tmp, dest_word_len);
3846 gfc_add_modify (&se->pre, size_bytes, tmp);
3847 gfc_add_modify (&se->pre, size_words,
3848 fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3849 size_bytes, dest_word_len));
3851 /* Evaluate the bounds of the result. If the loop range exists, we have
3852 to check if it is too large. If so, we modify loop->to be consistent
3853 with min(size, size(source)). Otherwise, size is made consistent with
3854 the loop range, so that the right number of bytes is transferred.*/
3855 n = se->loop->order[0];
3856 if (se->loop->to[n] != NULL_TREE)
3858 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3859 se->loop->to[n], se->loop->from[n]);
3860 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3861 tmp, gfc_index_one_node);
3862 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3864 gfc_add_modify (&se->pre, size_words, tmp);
3865 gfc_add_modify (&se->pre, size_bytes,
3866 fold_build2 (MULT_EXPR, gfc_array_index_type,
3867 size_words, dest_word_len));
3868 upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3869 size_words, se->loop->from[n]);
3870 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3871 upper, gfc_index_one_node);
3875 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3876 size_words, gfc_index_one_node);
3877 se->loop->from[n] = gfc_index_zero_node;
3880 se->loop->to[n] = upper;
3882 /* Build a destination descriptor, using the pointer, source, as the
3884 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3885 info, mold_type, NULL_TREE, false, true, false,
3888 /* Cast the pointer to the result. */
3889 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3890 tmp = fold_convert (pvoid_type_node, tmp);
3892 /* Use memcpy to do the transfer. */
3893 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3896 fold_convert (pvoid_type_node, source),
3897 fold_build2 (MIN_EXPR, gfc_array_index_type,
3898 size_bytes, source_bytes));
3899 gfc_add_expr_to_block (&se->pre, tmp);
3901 se->expr = info->descriptor;
3902 if (expr->ts.type == BT_CHARACTER)
3903 se->string_length = dest_word_len;
3907 /* Deal with scalar results. */
3909 extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
3910 dest_word_len, source_bytes);
3912 if (expr->ts.type == BT_CHARACTER)
3917 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
3918 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
3921 /* If source is longer than the destination, use a pointer to
3922 the source directly. */
3923 gfc_init_block (&block);
3924 gfc_add_modify (&block, tmpdecl, ptr);
3925 direct = gfc_finish_block (&block);
3927 /* Otherwise, allocate a string with the length of the destination
3928 and copy the source into it. */
3929 gfc_init_block (&block);
3930 tmp = gfc_get_pchar_type (expr->ts.kind);
3931 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
3932 gfc_add_modify (&block, tmpdecl,
3933 fold_convert (TREE_TYPE (ptr), tmp));
3934 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3935 fold_convert (pvoid_type_node, tmpdecl),
3936 fold_convert (pvoid_type_node, ptr),
3938 gfc_add_expr_to_block (&block, tmp);
3939 indirect = gfc_finish_block (&block);
3941 /* Wrap it up with the condition. */
3942 tmp = fold_build2 (LE_EXPR, boolean_type_node,
3943 dest_word_len, source_bytes);
3944 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
3945 gfc_add_expr_to_block (&se->pre, tmp);
3948 se->string_length = dest_word_len;
3952 tmpdecl = gfc_create_var (mold_type, "transfer");
3954 ptr = convert (build_pointer_type (mold_type), source);
3956 /* Use memcpy to do the transfer. */
3957 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
3958 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3959 fold_convert (pvoid_type_node, tmp),
3960 fold_convert (pvoid_type_node, ptr),
3962 gfc_add_expr_to_block (&se->pre, tmp);
3969 /* Generate code for the ALLOCATED intrinsic.
3970 Generate inline code that directly check the address of the argument. */
3973 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3975 gfc_actual_arglist *arg1;
3980 gfc_init_se (&arg1se, NULL);
3981 arg1 = expr->value.function.actual;
3982 ss1 = gfc_walk_expr (arg1->expr);
3983 arg1se.descriptor_only = 1;
3984 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3986 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3987 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3988 tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
3989 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3993 /* Generate code for the ASSOCIATED intrinsic.
3994 If both POINTER and TARGET are arrays, generate a call to library function
3995 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3996 In other cases, generate inline code that directly compare the address of
3997 POINTER with the address of TARGET. */
4000 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4002 gfc_actual_arglist *arg1;
4003 gfc_actual_arglist *arg2;
4008 tree nonzero_charlen;
4009 tree nonzero_arraylen;
4012 gfc_init_se (&arg1se, NULL);
4013 gfc_init_se (&arg2se, NULL);
4014 arg1 = expr->value.function.actual;
4016 ss1 = gfc_walk_expr (arg1->expr);
4020 /* No optional target. */
4021 if (ss1 == gfc_ss_terminator)
4023 /* A pointer to a scalar. */
4024 arg1se.want_pointer = 1;
4025 gfc_conv_expr (&arg1se, arg1->expr);
4030 /* A pointer to an array. */
4031 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4032 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4034 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4035 gfc_add_block_to_block (&se->post, &arg1se.post);
4036 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4037 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4042 /* An optional target. */
4043 ss2 = gfc_walk_expr (arg2->expr);
4045 nonzero_charlen = NULL_TREE;
4046 if (arg1->expr->ts.type == BT_CHARACTER)
4047 nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4048 arg1->expr->ts.cl->backend_decl,
4051 if (ss1 == gfc_ss_terminator)
4053 /* A pointer to a scalar. */
4054 gcc_assert (ss2 == gfc_ss_terminator);
4055 arg1se.want_pointer = 1;
4056 gfc_conv_expr (&arg1se, arg1->expr);
4057 arg2se.want_pointer = 1;
4058 gfc_conv_expr (&arg2se, arg2->expr);
4059 gfc_add_block_to_block (&se->pre, &arg1se.pre);
4060 gfc_add_block_to_block (&se->post, &arg1se.post);
4061 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4062 arg1se.expr, arg2se.expr);
4063 tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4064 arg1se.expr, null_pointer_node);
4065 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4070 /* An array pointer of zero length is not associated if target is
4072 arg1se.descriptor_only = 1;
4073 gfc_conv_expr_lhs (&arg1se, arg1->expr);
4074 tmp = gfc_conv_descriptor_stride (arg1se.expr,
4075 gfc_rank_cst[arg1->expr->rank - 1]);
4076 nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4077 build_int_cst (TREE_TYPE (tmp), 0));
4079 /* A pointer to an array, call library function _gfor_associated. */
4080 gcc_assert (ss2 != gfc_ss_terminator);
4081 arg1se.want_pointer = 1;
4082 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4084 arg2se.want_pointer = 1;
4085 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4086 gfc_add_block_to_block (&se->pre, &arg2se.pre);
4087 gfc_add_block_to_block (&se->post, &arg2se.post);
4088 se->expr = build_call_expr (gfor_fndecl_associated, 2,
4089 arg1se.expr, arg2se.expr);
4090 se->expr = convert (boolean_type_node, se->expr);
4091 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4092 se->expr, nonzero_arraylen);
4095 /* If target is present zero character length pointers cannot
4097 if (nonzero_charlen != NULL_TREE)
4098 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4099 se->expr, nonzero_charlen);
4102 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4106 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
4109 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4113 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4114 se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
4115 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4119 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
4122 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4126 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4128 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
4129 type = gfc_get_int_type (4);
4130 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4132 /* Convert it to the required type. */
4133 type = gfc_typenode_for_spec (&expr->ts);
4134 se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
4135 se->expr = fold_convert (type, se->expr);
4139 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
4142 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4144 gfc_actual_arglist *actual;
4149 for (actual = expr->value.function.actual; actual; actual = actual->next)
4151 gfc_init_se (&argse, se);
4153 /* Pass a NULL pointer for an absent arg. */
4154 if (actual->expr == NULL)
4155 argse.expr = null_pointer_node;
4161 if (actual->expr->ts.kind != gfc_c_int_kind)
4163 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
4164 ts.type = BT_INTEGER;
4165 ts.kind = gfc_c_int_kind;
4166 gfc_convert_type (actual->expr, &ts, 2);
4168 gfc_conv_expr_reference (&argse, actual->expr);
4171 gfc_add_block_to_block (&se->pre, &argse.pre);
4172 gfc_add_block_to_block (&se->post, &argse.post);
4173 args = gfc_chainon_list (args, argse.expr);
4176 /* Convert it to the required type. */
4177 type = gfc_typenode_for_spec (&expr->ts);
4178 se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
4179 se->expr = fold_convert (type, se->expr);
4183 /* Generate code for TRIM (A) intrinsic function. */
4186 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4196 unsigned int num_args;
4198 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4199 args = (tree *) alloca (sizeof (tree) * num_args);
4201 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4202 addr = gfc_build_addr_expr (ppvoid_type_node, var);
4203 len = gfc_create_var (gfc_get_int_type (4), "len");
4205 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4206 args[0] = gfc_build_addr_expr (NULL_TREE, len);
4209 if (expr->ts.kind == 1)
4210 function = gfor_fndecl_string_trim;
4211 else if (expr->ts.kind == 4)
4212 function = gfor_fndecl_string_trim_char4;
4216 fndecl = build_addr (function, current_function_decl);
4217 tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
4219 gfc_add_expr_to_block (&se->pre, tmp);
4221 /* Free the temporary afterwards, if necessary. */
4222 cond = fold_build2 (GT_EXPR, boolean_type_node,
4223 len, build_int_cst (TREE_TYPE (len), 0));
4224 tmp = gfc_call_free (var);
4225 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
4226 gfc_add_expr_to_block (&se->post, tmp);
4229 se->string_length = len;
4233 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
4236 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4238 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4239 tree type, cond, tmp, count, exit_label, n, max, largest;
4241 stmtblock_t block, body;
4244 /* We store in charsize the size of a character. */
4245 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4246 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4248 /* Get the arguments. */
4249 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4250 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4252 ncopies = gfc_evaluate_now (args[2], &se->pre);
4253 ncopies_type = TREE_TYPE (ncopies);
4255 /* Check that NCOPIES is not negative. */
4256 cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4257 build_int_cst (ncopies_type, 0));
4258 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4259 "Argument NCOPIES of REPEAT intrinsic is negative "
4260 "(its value is %lld)",
4261 fold_convert (long_integer_type_node, ncopies));
4263 /* If the source length is zero, any non negative value of NCOPIES
4264 is valid, and nothing happens. */
4265 n = gfc_create_var (ncopies_type, "ncopies");
4266 cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4267 build_int_cst (size_type_node, 0));
4268 tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4269 build_int_cst (ncopies_type, 0), ncopies);
4270 gfc_add_modify (&se->pre, n, tmp);
4273 /* Check that ncopies is not too large: ncopies should be less than
4274 (or equal to) MAX / slen, where MAX is the maximal integer of
4275 the gfc_charlen_type_node type. If slen == 0, we need a special
4276 case to avoid the division by zero. */
4277 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4278 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4279 max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4280 fold_convert (size_type_node, max), slen);
4281 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4282 ? size_type_node : ncopies_type;
4283 cond = fold_build2 (GT_EXPR, boolean_type_node,
4284 fold_convert (largest, ncopies),
4285 fold_convert (largest, max));
4286 tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4287 build_int_cst (size_type_node, 0));
4288 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4290 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4291 "Argument NCOPIES of REPEAT intrinsic is too large");
4293 /* Compute the destination length. */
4294 dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4295 fold_convert (gfc_charlen_type_node, slen),
4296 fold_convert (gfc_charlen_type_node, ncopies));
4297 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
4298 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4300 /* Generate the code to do the repeat operation:
4301 for (i = 0; i < ncopies; i++)
4302 memmove (dest + (i * slen * size), src, slen*size); */
4303 gfc_start_block (&block);
4304 count = gfc_create_var (ncopies_type, "count");
4305 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4306 exit_label = gfc_build_label_decl (NULL_TREE);
4308 /* Start the loop body. */
4309 gfc_start_block (&body);
4311 /* Exit the loop if count >= ncopies. */
4312 cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4313 tmp = build1_v (GOTO_EXPR, exit_label);
4314 TREE_USED (exit_label) = 1;
4315 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4316 build_empty_stmt ());
4317 gfc_add_expr_to_block (&body, tmp);
4319 /* Call memmove (dest + (i*slen*size), src, slen*size). */
4320 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4321 fold_convert (gfc_charlen_type_node, slen),
4322 fold_convert (gfc_charlen_type_node, count));
4323 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4324 tmp, fold_convert (gfc_charlen_type_node, size));
4325 tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4326 fold_convert (pvoid_type_node, dest),
4327 fold_convert (sizetype, tmp));
4328 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4329 fold_build2 (MULT_EXPR, size_type_node, slen,
4330 fold_convert (size_type_node, size)));
4331 gfc_add_expr_to_block (&body, tmp);
4333 /* Increment count. */
4334 tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4335 count, build_int_cst (TREE_TYPE (count), 1));
4336 gfc_add_modify (&body, count, tmp);
4338 /* Build the loop. */
4339 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4340 gfc_add_expr_to_block (&block, tmp);
4342 /* Add the exit label. */
4343 tmp = build1_v (LABEL_EXPR, exit_label);
4344 gfc_add_expr_to_block (&block, tmp);
4346 /* Finish the block. */
4347 tmp = gfc_finish_block (&block);
4348 gfc_add_expr_to_block (&se->pre, tmp);
4350 /* Set the result value. */
4352 se->string_length = dlen;
4356 /* Generate code for the IARGC intrinsic. */
4359 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4365 /* Call the library function. This always returns an INTEGER(4). */
4366 fndecl = gfor_fndecl_iargc;
4367 tmp = build_call_expr (fndecl, 0);
4369 /* Convert it to the required type. */
4370 type = gfc_typenode_for_spec (&expr->ts);
4371 tmp = fold_convert (type, tmp);
4377 /* The loc intrinsic returns the address of its argument as
4378 gfc_index_integer_kind integer. */
4381 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4387 gcc_assert (!se->ss);
4389 arg_expr = expr->value.function.actual->expr;
4390 ss = gfc_walk_expr (arg_expr);
4391 if (ss == gfc_ss_terminator)
4392 gfc_conv_expr_reference (se, arg_expr);
4394 gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL);
4395 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4397 /* Create a temporary variable for loc return value. Without this,
4398 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4399 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4400 gfc_add_modify (&se->pre, temp_var, se->expr);
4401 se->expr = temp_var;
4404 /* Generate code for an intrinsic function. Some map directly to library
4405 calls, others get special handling. In some cases the name of the function
4406 used depends on the type specifiers. */
4409 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4411 gfc_intrinsic_sym *isym;
4416 isym = expr->value.function.isym;
4418 name = &expr->value.function.name[2];
4420 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4422 lib = gfc_is_intrinsic_libcall (expr);
4426 se->ignore_optional = 1;
4428 switch (expr->value.function.isym->id)
4430 case GFC_ISYM_EOSHIFT:
4432 case GFC_ISYM_RESHAPE:
4433 /* For all of those the first argument specifies the type and the
4434 third is optional. */
4435 conv_generic_with_optional_char_arg (se, expr, 1, 3);
4439 gfc_conv_intrinsic_funcall (se, expr);
4447 switch (expr->value.function.isym->id)
4452 case GFC_ISYM_REPEAT:
4453 gfc_conv_intrinsic_repeat (se, expr);
4457 gfc_conv_intrinsic_trim (se, expr);
4460 case GFC_ISYM_SC_KIND:
4461 gfc_conv_intrinsic_sc_kind (se, expr);
4464 case GFC_ISYM_SI_KIND:
4465 gfc_conv_intrinsic_si_kind (se, expr);
4468 case GFC_ISYM_SR_KIND:
4469 gfc_conv_intrinsic_sr_kind (se, expr);
4472 case GFC_ISYM_EXPONENT:
4473 gfc_conv_intrinsic_exponent (se, expr);
4477 kind = expr->value.function.actual->expr->ts.kind;
4479 fndecl = gfor_fndecl_string_scan;
4481 fndecl = gfor_fndecl_string_scan_char4;
4485 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4488 case GFC_ISYM_VERIFY:
4489 kind = expr->value.function.actual->expr->ts.kind;
4491 fndecl = gfor_fndecl_string_verify;
4493 fndecl = gfor_fndecl_string_verify_char4;
4497 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4500 case GFC_ISYM_ALLOCATED:
4501 gfc_conv_allocated (se, expr);
4504 case GFC_ISYM_ASSOCIATED:
4505 gfc_conv_associated(se, expr);
4509 gfc_conv_intrinsic_abs (se, expr);
4512 case GFC_ISYM_ADJUSTL:
4513 if (expr->ts.kind == 1)
4514 fndecl = gfor_fndecl_adjustl;
4515 else if (expr->ts.kind == 4)
4516 fndecl = gfor_fndecl_adjustl_char4;
4520 gfc_conv_intrinsic_adjust (se, expr, fndecl);
4523 case GFC_ISYM_ADJUSTR:
4524 if (expr->ts.kind == 1)
4525 fndecl = gfor_fndecl_adjustr;
4526 else if (expr->ts.kind == 4)
4527 fndecl = gfor_fndecl_adjustr_char4;
4531 gfc_conv_intrinsic_adjust (se, expr, fndecl);
4534 case GFC_ISYM_AIMAG:
4535 gfc_conv_intrinsic_imagpart (se, expr);
4539 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4543 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4546 case GFC_ISYM_ANINT:
4547 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4551 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4555 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4558 case GFC_ISYM_BTEST:
4559 gfc_conv_intrinsic_btest (se, expr);
4562 case GFC_ISYM_ACHAR:
4564 gfc_conv_intrinsic_char (se, expr);
4567 case GFC_ISYM_CONVERSION:
4569 case GFC_ISYM_LOGICAL:
4571 gfc_conv_intrinsic_conversion (se, expr);
4574 /* Integer conversions are handled separately to make sure we get the
4575 correct rounding mode. */
4580 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
4584 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
4587 case GFC_ISYM_CEILING:
4588 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
4591 case GFC_ISYM_FLOOR:
4592 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
4596 gfc_conv_intrinsic_mod (se, expr, 0);
4599 case GFC_ISYM_MODULO:
4600 gfc_conv_intrinsic_mod (se, expr, 1);
4603 case GFC_ISYM_CMPLX:
4604 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
4607 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
4608 gfc_conv_intrinsic_iargc (se, expr);
4611 case GFC_ISYM_COMPLEX:
4612 gfc_conv_intrinsic_cmplx (se, expr, 1);
4615 case GFC_ISYM_CONJG:
4616 gfc_conv_intrinsic_conjg (se, expr);
4619 case GFC_ISYM_COUNT:
4620 gfc_conv_intrinsic_count (se, expr);
4623 case GFC_ISYM_CTIME:
4624 gfc_conv_intrinsic_ctime (se, expr);
4628 gfc_conv_intrinsic_dim (se, expr);
4631 case GFC_ISYM_DOT_PRODUCT:
4632 gfc_conv_intrinsic_dot_product (se, expr);
4635 case GFC_ISYM_DPROD:
4636 gfc_conv_intrinsic_dprod (se, expr);
4639 case GFC_ISYM_FDATE:
4640 gfc_conv_intrinsic_fdate (se, expr);
4643 case GFC_ISYM_FRACTION:
4644 gfc_conv_intrinsic_fraction (se, expr);
4648 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4651 case GFC_ISYM_IBCLR:
4652 gfc_conv_intrinsic_singlebitop (se, expr, 0);
4655 case GFC_ISYM_IBITS:
4656 gfc_conv_intrinsic_ibits (se, expr);
4659 case GFC_ISYM_IBSET:
4660 gfc_conv_intrinsic_singlebitop (se, expr, 1);
4663 case GFC_ISYM_IACHAR:
4664 case GFC_ISYM_ICHAR:
4665 /* We assume ASCII character sequence. */
4666 gfc_conv_intrinsic_ichar (se, expr);
4669 case GFC_ISYM_IARGC:
4670 gfc_conv_intrinsic_iargc (se, expr);
4674 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4677 case GFC_ISYM_INDEX:
4678 kind = expr->value.function.actual->expr->ts.kind;
4680 fndecl = gfor_fndecl_string_index;
4682 fndecl = gfor_fndecl_string_index_char4;
4686 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4690 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4693 case GFC_ISYM_IS_IOSTAT_END:
4694 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
4697 case GFC_ISYM_IS_IOSTAT_EOR:
4698 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
4701 case GFC_ISYM_ISNAN:
4702 gfc_conv_intrinsic_isnan (se, expr);
4705 case GFC_ISYM_LSHIFT:
4706 gfc_conv_intrinsic_rlshift (se, expr, 0);
4709 case GFC_ISYM_RSHIFT:
4710 gfc_conv_intrinsic_rlshift (se, expr, 1);
4713 case GFC_ISYM_ISHFT:
4714 gfc_conv_intrinsic_ishft (se, expr);
4717 case GFC_ISYM_ISHFTC:
4718 gfc_conv_intrinsic_ishftc (se, expr);
4721 case GFC_ISYM_LEADZ:
4722 gfc_conv_intrinsic_leadz (se, expr);
4725 case GFC_ISYM_TRAILZ:
4726 gfc_conv_intrinsic_trailz (se, expr);
4729 case GFC_ISYM_LBOUND:
4730 gfc_conv_intrinsic_bound (se, expr, 0);
4733 case GFC_ISYM_TRANSPOSE:
4734 if (se->ss && se->ss->useflags)
4736 gfc_conv_tmp_array_ref (se);
4737 gfc_advance_se_ss_chain (se);
4740 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4744 gfc_conv_intrinsic_len (se, expr);
4747 case GFC_ISYM_LEN_TRIM:
4748 gfc_conv_intrinsic_len_trim (se, expr);
4752 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4756 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4760 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4764 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4768 if (expr->ts.type == BT_CHARACTER)
4769 gfc_conv_intrinsic_minmax_char (se, expr, 1);
4771 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4774 case GFC_ISYM_MAXLOC:
4775 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4778 case GFC_ISYM_MAXVAL:
4779 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4782 case GFC_ISYM_MERGE:
4783 gfc_conv_intrinsic_merge (se, expr);
4787 if (expr->ts.type == BT_CHARACTER)
4788 gfc_conv_intrinsic_minmax_char (se, expr, -1);
4790 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4793 case GFC_ISYM_MINLOC:
4794 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4797 case GFC_ISYM_MINVAL:
4798 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4801 case GFC_ISYM_NEAREST:
4802 gfc_conv_intrinsic_nearest (se, expr);
4806 gfc_conv_intrinsic_not (se, expr);
4810 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4813 case GFC_ISYM_PRESENT:
4814 gfc_conv_intrinsic_present (se, expr);
4817 case GFC_ISYM_PRODUCT:
4818 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4821 case GFC_ISYM_RRSPACING:
4822 gfc_conv_intrinsic_rrspacing (se, expr);
4825 case GFC_ISYM_SET_EXPONENT:
4826 gfc_conv_intrinsic_set_exponent (se, expr);
4829 case GFC_ISYM_SCALE:
4830 gfc_conv_intrinsic_scale (se, expr);
4834 gfc_conv_intrinsic_sign (se, expr);
4838 gfc_conv_intrinsic_size (se, expr);
4841 case GFC_ISYM_SIZEOF:
4842 gfc_conv_intrinsic_sizeof (se, expr);
4845 case GFC_ISYM_SPACING:
4846 gfc_conv_intrinsic_spacing (se, expr);
4850 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4853 case GFC_ISYM_TRANSFER:
4854 if (se->ss && se->ss->useflags)
4856 /* Access the previously obtained result. */
4857 gfc_conv_tmp_array_ref (se);
4858 gfc_advance_se_ss_chain (se);
4861 gfc_conv_intrinsic_transfer (se, expr);
4864 case GFC_ISYM_TTYNAM:
4865 gfc_conv_intrinsic_ttynam (se, expr);
4868 case GFC_ISYM_UBOUND:
4869 gfc_conv_intrinsic_bound (se, expr, 1);
4873 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4877 gfc_conv_intrinsic_loc (se, expr);
4880 case GFC_ISYM_ACCESS:
4881 case GFC_ISYM_CHDIR:
4882 case GFC_ISYM_CHMOD:
4883 case GFC_ISYM_DTIME:
4884 case GFC_ISYM_ETIME:
4886 case GFC_ISYM_FGETC:
4889 case GFC_ISYM_FPUTC:
4890 case GFC_ISYM_FSTAT:
4891 case GFC_ISYM_FTELL:
4892 case GFC_ISYM_GETCWD:
4893 case GFC_ISYM_GETGID:
4894 case GFC_ISYM_GETPID:
4895 case GFC_ISYM_GETUID:
4896 case GFC_ISYM_HOSTNM:
4898 case GFC_ISYM_IERRNO:
4899 case GFC_ISYM_IRAND:
4900 case GFC_ISYM_ISATTY:
4902 case GFC_ISYM_LSTAT:
4903 case GFC_ISYM_MALLOC:
4904 case GFC_ISYM_MATMUL:
4905 case GFC_ISYM_MCLOCK:
4906 case GFC_ISYM_MCLOCK8:
4908 case GFC_ISYM_RENAME:
4909 case GFC_ISYM_SECOND:
4910 case GFC_ISYM_SECNDS:
4911 case GFC_ISYM_SIGNAL:
4913 case GFC_ISYM_SYMLNK:
4914 case GFC_ISYM_SYSTEM:
4916 case GFC_ISYM_TIME8:
4917 case GFC_ISYM_UMASK:
4918 case GFC_ISYM_UNLINK:
4919 gfc_conv_intrinsic_funcall (se, expr);
4922 case GFC_ISYM_EOSHIFT:
4924 case GFC_ISYM_RESHAPE:
4925 /* For those, expr->rank should always be >0 and thus the if above the
4926 switch should have matched. */
4931 gfc_conv_intrinsic_lib_function (se, expr);
4937 /* This generates code to execute before entering the scalarization loop.
4938 Currently does nothing. */
4941 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4943 switch (ss->expr->value.function.isym->id)
4945 case GFC_ISYM_UBOUND:
4946 case GFC_ISYM_LBOUND:
4955 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4956 inside the scalarization loop. */
4959 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4963 /* The two argument version returns a scalar. */
4964 if (expr->value.function.actual->next->expr)
4967 newss = gfc_get_ss ();
4968 newss->type = GFC_SS_INTRINSIC;
4971 newss->data.info.dimen = 1;
4977 /* Walk an intrinsic array libcall. */
4980 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4984 gcc_assert (expr->rank > 0);
4986 newss = gfc_get_ss ();
4987 newss->type = GFC_SS_FUNCTION;
4990 newss->data.info.dimen = expr->rank;
4996 /* Returns nonzero if the specified intrinsic function call maps directly to
4997 an external library call. Should only be used for functions that return
5001 gfc_is_intrinsic_libcall (gfc_expr * expr)
5003 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5004 gcc_assert (expr->rank > 0);
5006 switch (expr->value.function.isym->id)
5010 case GFC_ISYM_COUNT:
5011 case GFC_ISYM_MATMUL:
5012 case GFC_ISYM_MAXLOC:
5013 case GFC_ISYM_MAXVAL:
5014 case GFC_ISYM_MINLOC:
5015 case GFC_ISYM_MINVAL:
5016 case GFC_ISYM_PRODUCT:
5018 case GFC_ISYM_SHAPE:
5019 case GFC_ISYM_SPREAD:
5020 case GFC_ISYM_TRANSPOSE:
5021 /* Ignore absent optional parameters. */
5024 case GFC_ISYM_RESHAPE:
5025 case GFC_ISYM_CSHIFT:
5026 case GFC_ISYM_EOSHIFT:
5028 case GFC_ISYM_UNPACK:
5029 /* Pass absent optional parameters. */
5037 /* Walk an intrinsic function. */
5039 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5040 gfc_intrinsic_sym * isym)
5044 if (isym->elemental)
5045 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5047 if (expr->rank == 0)
5050 if (gfc_is_intrinsic_libcall (expr))
5051 return gfc_walk_intrinsic_libfunc (ss, expr);
5053 /* Special cases. */
5056 case GFC_ISYM_LBOUND:
5057 case GFC_ISYM_UBOUND:
5058 return gfc_walk_intrinsic_bound (ss, expr);
5060 case GFC_ISYM_TRANSFER:
5061 return gfc_walk_intrinsic_libfunc (ss, expr);
5064 /* This probably meant someone forgot to add an intrinsic to the above
5065 list(s) when they implemented it, or something's gone horribly
5071 #include "gt-fortran-trans-intrinsic.h"