1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
32 #include "tree-gimple.h"
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct gfc_intrinsic_map_t
GTY(())
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
51 enum gfc_generic_isym_id id
;
53 /* Enum value from the "language-independent", aka C-centric, part
54 of gcc, or END_BUILTINS of no such value set. */
55 enum built_in_function code_r4
;
56 enum built_in_function code_r8
;
57 enum built_in_function code_r10
;
58 enum built_in_function code_r16
;
59 enum built_in_function code_c4
;
60 enum built_in_function code_c8
;
61 enum built_in_function code_c10
;
62 enum built_in_function code_c16
;
64 /* True if the naming pattern is to prepend "c" for complex and
65 append "f" for kind=4. False if the naming pattern is to
66 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
69 /* True if a complex version of the function exists. */
70 bool complex_available
;
72 /* True if the function should be marked const. */
75 /* The base library name of this function. */
78 /* Cache decls created for the various operand types. */
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 defines complex variants of all of the entries in mathbuiltins.def
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
96 false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
102 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
103 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
106 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
112 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
113 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
116 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
118 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
120 /* Functions built into gcc itself. */
121 #include "mathbuiltins.def"
123 /* Functions in libm. */
124 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
125 pattern for other mathbuiltins.def entries. At present we have no
126 optimizations for this in the common sources. */
127 LIBM_FUNCTION (SCALE
, "scalbn", false),
129 /* Functions in libgfortran. */
130 LIBF_FUNCTION (FRACTION
, "fraction", false),
131 LIBF_FUNCTION (NEAREST
, "nearest", false),
132 LIBF_FUNCTION (SET_EXPONENT
, "set_exponent", false),
135 LIBF_FUNCTION (NONE
, NULL
, false)
137 #undef DEFINE_MATH_BUILTIN
138 #undef DEFINE_MATH_BUILTIN_C
142 /* Structure for storing components of a floating number to be used by
143 elemental functions to manipulate reals. */
146 tree arg
; /* Variable tree to view convert to integer. */
147 tree expn
; /* Variable tree to save exponent. */
148 tree frac
; /* Variable tree to save fraction. */
149 tree smask
; /* Constant tree of sign's mask. */
150 tree emask
; /* Constant tree of exponent's mask. */
151 tree fmask
; /* Constant tree of fraction's mask. */
152 tree edigits
; /* Constant tree of the number of exponent bits. */
153 tree fdigits
; /* Constant tree of the number of fraction bits. */
154 tree f1
; /* Constant tree of the f1 defined in the real model. */
155 tree bias
; /* Constant tree of the bias of exponent in the memory. */
156 tree type
; /* Type tree of arg1. */
157 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
162 /* Evaluate the arguments to an intrinsic function. */
165 gfc_conv_intrinsic_function_args (gfc_se
* se
, gfc_expr
* expr
)
167 gfc_actual_arglist
*actual
;
169 gfc_intrinsic_arg
*formal
;
174 formal
= expr
->value
.function
.isym
->formal
;
176 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
,
177 formal
= formal
? formal
->next
: NULL
)
180 /* Skip omitted optional arguments. */
184 /* Evaluate the parameter. This will substitute scalarized
185 references automatically. */
186 gfc_init_se (&argse
, se
);
188 if (e
->ts
.type
== BT_CHARACTER
)
190 gfc_conv_expr (&argse
, e
);
191 gfc_conv_string_parameter (&argse
);
192 args
= gfc_chainon_list (args
, argse
.string_length
);
195 gfc_conv_expr_val (&argse
, e
);
197 /* If an optional argument is itself an optional dummy argument,
198 check its presence and substitute a null if absent. */
199 if (e
->expr_type
==EXPR_VARIABLE
200 && e
->symtree
->n
.sym
->attr
.optional
203 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
);
205 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
206 gfc_add_block_to_block (&se
->post
, &argse
.post
);
207 args
= gfc_chainon_list (args
, argse
.expr
);
213 /* Conversions between different types are output by the frontend as
214 intrinsic functions. We implement these directly with inline code. */
217 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
222 /* Evaluate the argument. */
223 type
= gfc_typenode_for_spec (&expr
->ts
);
224 gcc_assert (expr
->value
.function
.actual
->expr
);
225 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
226 arg
= TREE_VALUE (arg
);
228 /* Conversion from complex to non-complex involves taking the real
229 component of the value. */
230 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
231 && expr
->ts
.type
!= BT_COMPLEX
)
235 artype
= TREE_TYPE (TREE_TYPE (arg
));
236 arg
= build1 (REALPART_EXPR
, artype
, arg
);
239 se
->expr
= convert (type
, arg
);
242 /* This is needed because the gcc backend only implements
243 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
244 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
245 Similarly for CEILING. */
248 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
255 argtype
= TREE_TYPE (arg
);
256 arg
= gfc_evaluate_now (arg
, pblock
);
258 intval
= convert (type
, arg
);
259 intval
= gfc_evaluate_now (intval
, pblock
);
261 tmp
= convert (argtype
, intval
);
262 cond
= build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
264 tmp
= build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
265 build_int_cst (type
, 1));
266 tmp
= build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
271 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
272 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
275 build_round_expr (stmtblock_t
* pblock
, tree arg
, tree type
)
284 argtype
= TREE_TYPE (arg
);
285 arg
= gfc_evaluate_now (arg
, pblock
);
287 real_from_string (&r
, "0.5");
288 pos
= build_real (argtype
, r
);
290 real_from_string (&r
, "-0.5");
291 neg
= build_real (argtype
, r
);
293 tmp
= gfc_build_const (argtype
, integer_zero_node
);
294 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
296 tmp
= fold_build3 (COND_EXPR
, argtype
, cond
, pos
, neg
);
297 tmp
= fold_build2 (PLUS_EXPR
, argtype
, arg
, tmp
);
298 return fold_build1 (FIX_TRUNC_EXPR
, type
, tmp
);
302 /* Convert a real to an integer using a specific rounding mode.
303 Ideally we would just build the corresponding GENERIC node,
304 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
307 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
313 return build_fixbound_expr (pblock
, arg
, type
, 0);
317 return build_fixbound_expr (pblock
, arg
, type
, 1);
321 return build_round_expr (pblock
, arg
, type
);
324 return build1 (op
, type
, arg
);
329 /* Round a real value using the specified rounding mode.
330 We use a temporary integer of that same kind size as the result.
331 Values larger than those that can be represented by this kind are
332 unchanged, as thay will not be accurate enough to represent the
334 huge = HUGE (KIND (a))
335 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
339 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
350 kind
= expr
->ts
.kind
;
353 /* We have builtin functions for some cases. */
396 /* Evaluate the argument. */
397 gcc_assert (expr
->value
.function
.actual
->expr
);
398 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
400 /* Use a builtin function if one exists. */
401 if (n
!= END_BUILTINS
)
403 tmp
= built_in_decls
[n
];
404 se
->expr
= build_function_call_expr (tmp
, arg
);
408 /* This code is probably redundant, but we'll keep it lying around just
410 type
= gfc_typenode_for_spec (&expr
->ts
);
411 arg
= TREE_VALUE (arg
);
412 arg
= gfc_evaluate_now (arg
, &se
->pre
);
414 /* Test if the value is too large to handle sensibly. */
415 gfc_set_model_kind (kind
);
417 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
418 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
419 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
420 cond
= build2 (LT_EXPR
, boolean_type_node
, arg
, tmp
);
422 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
423 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
424 tmp
= build2 (GT_EXPR
, boolean_type_node
, arg
, tmp
);
425 cond
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
426 itype
= gfc_get_int_type (kind
);
428 tmp
= build_fix_expr (&se
->pre
, arg
, itype
, op
);
429 tmp
= convert (type
, tmp
);
430 se
->expr
= build3 (COND_EXPR
, type
, cond
, tmp
, arg
);
435 /* Convert to an integer using the specified rounding mode. */
438 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, int op
)
443 /* Evaluate the argument. */
444 type
= gfc_typenode_for_spec (&expr
->ts
);
445 gcc_assert (expr
->value
.function
.actual
->expr
);
446 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
447 arg
= TREE_VALUE (arg
);
449 if (TREE_CODE (TREE_TYPE (arg
)) == INTEGER_TYPE
)
451 /* Conversion to a different integer kind. */
452 se
->expr
= convert (type
, arg
);
456 /* Conversion from complex to non-complex involves taking the real
457 component of the value. */
458 if (TREE_CODE (TREE_TYPE (arg
)) == COMPLEX_TYPE
459 && expr
->ts
.type
!= BT_COMPLEX
)
463 artype
= TREE_TYPE (TREE_TYPE (arg
));
464 arg
= build1 (REALPART_EXPR
, artype
, arg
);
467 se
->expr
= build_fix_expr (&se
->pre
, arg
, type
, op
);
472 /* Get the imaginary component of a value. */
475 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
479 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
480 arg
= TREE_VALUE (arg
);
481 se
->expr
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
485 /* Get the complex conjugate of a value. */
488 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
492 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
493 arg
= TREE_VALUE (arg
);
494 se
->expr
= build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
498 /* Initialize function decls for library functions. The external functions
499 are created as required. Builtin functions are added here. */
502 gfc_build_intrinsic_lib_fndecls (void)
504 gfc_intrinsic_map_t
*m
;
506 /* Add GCC builtin functions. */
507 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
509 if (m
->code_r4
!= END_BUILTINS
)
510 m
->real4_decl
= built_in_decls
[m
->code_r4
];
511 if (m
->code_r8
!= END_BUILTINS
)
512 m
->real8_decl
= built_in_decls
[m
->code_r8
];
513 if (m
->code_r10
!= END_BUILTINS
)
514 m
->real10_decl
= built_in_decls
[m
->code_r10
];
515 if (m
->code_r16
!= END_BUILTINS
)
516 m
->real16_decl
= built_in_decls
[m
->code_r16
];
517 if (m
->code_c4
!= END_BUILTINS
)
518 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
519 if (m
->code_c8
!= END_BUILTINS
)
520 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
521 if (m
->code_c10
!= END_BUILTINS
)
522 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
523 if (m
->code_c16
!= END_BUILTINS
)
524 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
529 /* Create a fndecl for a simple intrinsic library function. */
532 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
537 gfc_actual_arglist
*actual
;
540 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
543 if (ts
->type
== BT_REAL
)
548 pdecl
= &m
->real4_decl
;
551 pdecl
= &m
->real8_decl
;
554 pdecl
= &m
->real10_decl
;
557 pdecl
= &m
->real16_decl
;
563 else if (ts
->type
== BT_COMPLEX
)
565 gcc_assert (m
->complex_available
);
570 pdecl
= &m
->complex4_decl
;
573 pdecl
= &m
->complex8_decl
;
576 pdecl
= &m
->complex10_decl
;
579 pdecl
= &m
->complex16_decl
;
593 gcc_assert (ts
->kind
== 4 || ts
->kind
== 8 || ts
->kind
== 10
595 snprintf (name
, sizeof (name
), "%s%s%s",
596 ts
->type
== BT_COMPLEX
? "c" : "",
598 ts
->kind
== 4 ? "f" : "");
602 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
603 ts
->type
== BT_COMPLEX
? 'c' : 'r',
607 argtypes
= NULL_TREE
;
608 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
610 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
611 argtypes
= gfc_chainon_list (argtypes
, type
);
613 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
614 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
615 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
617 /* Mark the decl as external. */
618 DECL_EXTERNAL (fndecl
) = 1;
619 TREE_PUBLIC (fndecl
) = 1;
621 /* Mark it __attribute__((const)), if possible. */
622 TREE_READONLY (fndecl
) = m
->is_constant
;
624 rest_of_decl_compilation (fndecl
, 1, 0);
631 /* Convert an intrinsic function into an external or builtin call. */
634 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
636 gfc_intrinsic_map_t
*m
;
639 gfc_generic_isym_id id
;
641 id
= expr
->value
.function
.isym
->generic_id
;
642 /* Find the entry for this function. */
643 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
649 if (m
->id
== GFC_ISYM_NONE
)
651 internal_error ("Intrinsic function %s(%d) not recognized",
652 expr
->value
.function
.name
, id
);
655 /* Get the decl and generate the call. */
656 args
= gfc_conv_intrinsic_function_args (se
, expr
);
657 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
658 se
->expr
= build_function_call_expr (fndecl
, args
);
661 /* Generate code for EXPONENT(X) intrinsic function. */
664 gfc_conv_intrinsic_exponent (gfc_se
* se
, gfc_expr
* expr
)
669 args
= gfc_conv_intrinsic_function_args (se
, expr
);
671 a1
= expr
->value
.function
.actual
->expr
;
675 fndecl
= gfor_fndecl_math_exponent4
;
678 fndecl
= gfor_fndecl_math_exponent8
;
681 fndecl
= gfor_fndecl_math_exponent10
;
684 fndecl
= gfor_fndecl_math_exponent16
;
690 se
->expr
= build_function_call_expr (fndecl
, args
);
693 /* Evaluate a single upper or lower bound. */
694 /* TODO: bound intrinsic generates way too much unnecessary code. */
697 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
699 gfc_actual_arglist
*arg
;
700 gfc_actual_arglist
*arg2
;
710 arg
= expr
->value
.function
.actual
;
715 /* Create an implicit second parameter from the loop variable. */
716 gcc_assert (!arg2
->expr
);
717 gcc_assert (se
->loop
->dimen
== 1);
718 gcc_assert (se
->ss
->expr
== expr
);
719 gfc_advance_se_ss_chain (se
);
720 bound
= se
->loop
->loopvar
[0];
721 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
726 /* use the passed argument. */
727 gcc_assert (arg
->next
->expr
);
728 gfc_init_se (&argse
, NULL
);
729 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
730 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
732 /* Convert from one based to zero based. */
733 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
737 /* TODO: don't re-evaluate the descriptor on each iteration. */
738 /* Get a descriptor for the first parameter. */
739 ss
= gfc_walk_expr (arg
->expr
);
740 gcc_assert (ss
!= gfc_ss_terminator
);
741 gfc_init_se (&argse
, NULL
);
742 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
743 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
744 gfc_add_block_to_block (&se
->post
, &argse
.post
);
748 if (INTEGER_CST_P (bound
))
750 gcc_assert (TREE_INT_CST_HIGH (bound
) == 0);
751 i
= TREE_INT_CST_LOW (bound
);
752 gcc_assert (i
>= 0 && i
< GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)));
756 if (flag_bounds_check
)
758 bound
= gfc_evaluate_now (bound
, &se
->pre
);
759 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
760 bound
, build_int_cst (TREE_TYPE (bound
), 0));
761 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
762 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
763 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
764 gfc_trans_runtime_check (cond
, gfc_strconst_fault
, &se
->pre
);
769 se
->expr
= gfc_conv_descriptor_ubound(desc
, bound
);
771 se
->expr
= gfc_conv_descriptor_lbound(desc
, bound
);
773 type
= gfc_typenode_for_spec (&expr
->ts
);
774 se
->expr
= convert (type
, se
->expr
);
779 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
785 args
= gfc_conv_intrinsic_function_args (se
, expr
);
786 gcc_assert (args
&& TREE_CHAIN (args
) == NULL_TREE
);
787 val
= TREE_VALUE (args
);
789 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
793 se
->expr
= build1 (ABS_EXPR
, TREE_TYPE (val
), val
);
797 switch (expr
->ts
.kind
)
812 se
->expr
= build_function_call_expr (built_in_decls
[n
], args
);
821 /* Create a complex value from one or two real components. */
824 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
831 type
= gfc_typenode_for_spec (&expr
->ts
);
832 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
833 real
= convert (TREE_TYPE (type
), TREE_VALUE (arg
));
835 imag
= convert (TREE_TYPE (type
), TREE_VALUE (TREE_CHAIN (arg
)));
836 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg
))) == COMPLEX_TYPE
)
838 arg
= TREE_VALUE (arg
);
839 imag
= build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
840 imag
= convert (TREE_TYPE (type
), imag
);
843 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
845 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
848 /* Remainder function MOD(A, P) = A - INT(A / P) * P
849 MODULO(A, P) = A - FLOOR (A / P) * P */
850 /* TODO: MOD(x, 0) */
853 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
865 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
866 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
867 arg
= TREE_VALUE (arg
);
868 type
= TREE_TYPE (arg
);
870 switch (expr
->ts
.type
)
873 /* Integer case is easy, we've got a builtin op. */
875 se
->expr
= build2 (FLOOR_MOD_EXPR
, type
, arg
, arg2
);
877 se
->expr
= build2 (TRUNC_MOD_EXPR
, type
, arg
, arg2
);
881 /* Real values we have to do the hard way. */
882 arg
= gfc_evaluate_now (arg
, &se
->pre
);
883 arg2
= gfc_evaluate_now (arg2
, &se
->pre
);
885 tmp
= build2 (RDIV_EXPR
, type
, arg
, arg2
);
886 /* Test if the value is too large to handle sensibly. */
887 gfc_set_model_kind (expr
->ts
.kind
);
889 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
890 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
891 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
892 test2
= build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
894 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
895 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
896 test
= build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
897 test2
= build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
899 itype
= gfc_get_int_type (expr
->ts
.kind
);
901 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_FLOOR_EXPR
);
903 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, FIX_TRUNC_EXPR
);
904 tmp
= convert (type
, tmp
);
905 tmp
= build3 (COND_EXPR
, type
, test2
, tmp
, arg
);
906 tmp
= build2 (MULT_EXPR
, type
, tmp
, arg2
);
907 se
->expr
= build2 (MINUS_EXPR
, type
, arg
, tmp
);
916 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
919 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
928 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
929 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
930 arg
= TREE_VALUE (arg
);
931 type
= TREE_TYPE (arg
);
933 val
= build2 (MINUS_EXPR
, type
, arg
, arg2
);
934 val
= gfc_evaluate_now (val
, &se
->pre
);
936 zero
= gfc_build_const (type
, integer_zero_node
);
937 tmp
= build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
938 se
->expr
= build3 (COND_EXPR
, type
, tmp
, zero
, val
);
942 /* SIGN(A, B) is absolute value of A times sign of B.
943 The real value versions use library functions to ensure the correct
944 handling of negative zero. Integer case implemented as:
945 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
949 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
960 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
961 if (expr
->ts
.type
== BT_REAL
)
963 switch (expr
->ts
.kind
)
966 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
969 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
973 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
978 se
->expr
= build_function_call_expr (tmp
, arg
);
982 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
983 arg
= TREE_VALUE (arg
);
984 type
= TREE_TYPE (arg
);
985 zero
= gfc_build_const (type
, integer_zero_node
);
987 testa
= fold_build2 (GE_EXPR
, boolean_type_node
, arg
, zero
);
988 testb
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
, zero
);
989 tmp
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, testa
, testb
);
990 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
,
991 build1 (NEGATE_EXPR
, type
, arg
), arg
);
995 /* Test for the presence of an optional argument. */
998 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1002 arg
= expr
->value
.function
.actual
->expr
;
1003 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1004 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1005 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1009 /* Calculate the double precision product of two single precision values. */
1012 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1018 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1019 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
1020 arg
= TREE_VALUE (arg
);
1022 /* Convert the args to double precision before multiplying. */
1023 type
= gfc_typenode_for_spec (&expr
->ts
);
1024 arg
= convert (type
, arg
);
1025 arg2
= convert (type
, arg2
);
1026 se
->expr
= build2 (MULT_EXPR
, type
, arg
, arg2
);
1030 /* Return a length one character string containing an ascii character. */
1033 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1039 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1040 arg
= TREE_VALUE (arg
);
1042 /* We currently don't support character types != 1. */
1043 gcc_assert (expr
->ts
.kind
== 1);
1044 type
= gfc_character1_type_node
;
1045 var
= gfc_create_var (type
, "char");
1047 arg
= convert (type
, arg
);
1048 gfc_add_modify_expr (&se
->pre
, var
, arg
);
1049 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1050 se
->string_length
= integer_one_node
;
1055 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1063 tree gfc_int8_type_node
= gfc_get_int_type (8);
1065 type
= build_pointer_type (gfc_character1_type_node
);
1066 var
= gfc_create_var (type
, "pstr");
1067 len
= gfc_create_var (gfc_int8_type_node
, "len");
1069 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1070 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1071 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1072 arglist
= chainon (arglist
, tmp
);
1074 tmp
= build_function_call_expr (gfor_fndecl_ctime
, arglist
);
1075 gfc_add_expr_to_block (&se
->pre
, tmp
);
1077 /* Free the temporary afterwards, if necessary. */
1078 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1079 build_int_cst (TREE_TYPE (len
), 0));
1080 arglist
= gfc_chainon_list (NULL_TREE
, var
);
1081 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
1082 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1083 gfc_add_expr_to_block (&se
->post
, tmp
);
1086 se
->string_length
= len
;
1091 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1099 tree gfc_int4_type_node
= gfc_get_int_type (4);
1101 type
= build_pointer_type (gfc_character1_type_node
);
1102 var
= gfc_create_var (type
, "pstr");
1103 len
= gfc_create_var (gfc_int4_type_node
, "len");
1105 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1106 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1107 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1108 arglist
= chainon (arglist
, tmp
);
1110 tmp
= build_function_call_expr (gfor_fndecl_fdate
, arglist
);
1111 gfc_add_expr_to_block (&se
->pre
, tmp
);
1113 /* Free the temporary afterwards, if necessary. */
1114 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1115 build_int_cst (TREE_TYPE (len
), 0));
1116 arglist
= gfc_chainon_list (NULL_TREE
, var
);
1117 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
1118 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1119 gfc_add_expr_to_block (&se
->post
, tmp
);
1122 se
->string_length
= len
;
1126 /* Return a character string containing the tty name. */
1129 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1137 tree gfc_int4_type_node
= gfc_get_int_type (4);
1139 type
= build_pointer_type (gfc_character1_type_node
);
1140 var
= gfc_create_var (type
, "pstr");
1141 len
= gfc_create_var (gfc_int4_type_node
, "len");
1143 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
1144 arglist
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (var
));
1145 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
1146 arglist
= chainon (arglist
, tmp
);
1148 tmp
= build_function_call_expr (gfor_fndecl_ttynam
, arglist
);
1149 gfc_add_expr_to_block (&se
->pre
, tmp
);
1151 /* Free the temporary afterwards, if necessary. */
1152 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
1153 build_int_cst (TREE_TYPE (len
), 0));
1154 arglist
= gfc_chainon_list (NULL_TREE
, var
);
1155 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
1156 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1157 gfc_add_expr_to_block (&se
->post
, tmp
);
1160 se
->string_length
= len
;
1164 /* Get the minimum/maximum value of all the parameters.
1165 minmax (a1, a2, a3, ...)
1178 /* TODO: Mismatching types can occur when specific names are used.
1179 These should be handled during resolution. */
1181 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1192 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
1193 type
= gfc_typenode_for_spec (&expr
->ts
);
1195 limit
= TREE_VALUE (arg
);
1196 if (TREE_TYPE (limit
) != type
)
1197 limit
= convert (type
, limit
);
1198 /* Only evaluate the argument once. */
1199 if (TREE_CODE (limit
) != VAR_DECL
&& !TREE_CONSTANT (limit
))
1200 limit
= gfc_evaluate_now(limit
, &se
->pre
);
1202 mvar
= gfc_create_var (type
, "M");
1203 elsecase
= build2_v (MODIFY_EXPR
, mvar
, limit
);
1204 for (arg
= TREE_CHAIN (arg
); arg
!= NULL_TREE
; arg
= TREE_CHAIN (arg
))
1206 val
= TREE_VALUE (arg
);
1207 if (TREE_TYPE (val
) != type
)
1208 val
= convert (type
, val
);
1210 /* Only evaluate the argument once. */
1211 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1212 val
= gfc_evaluate_now(val
, &se
->pre
);
1214 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1216 tmp
= build2 (op
, boolean_type_node
, val
, limit
);
1217 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
1218 gfc_add_expr_to_block (&se
->pre
, tmp
);
1219 elsecase
= build_empty_stmt ();
1226 /* Create a symbol node for this intrinsic. The symbol from the frontend
1227 has the generic name. */
1230 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1234 /* TODO: Add symbols for intrinsic function to the global namespace. */
1235 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1236 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1239 sym
->attr
.external
= 1;
1240 sym
->attr
.function
= 1;
1241 sym
->attr
.always_explicit
= 1;
1242 sym
->attr
.proc
= PROC_INTRINSIC
;
1243 sym
->attr
.flavor
= FL_PROCEDURE
;
1247 sym
->attr
.dimension
= 1;
1248 sym
->as
= gfc_get_array_spec ();
1249 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1250 sym
->as
->rank
= expr
->rank
;
1253 /* TODO: proper argument lists for external intrinsics. */
1257 /* Generate a call to an external intrinsic function. */
1259 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1263 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1266 gcc_assert (expr
->rank
> 0);
1268 gcc_assert (expr
->rank
== 0);
1270 sym
= gfc_get_symbol_for_expr (expr
);
1271 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1275 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1295 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1304 gfc_actual_arglist
*actual
;
1311 gfc_conv_intrinsic_funcall (se
, expr
);
1315 actual
= expr
->value
.function
.actual
;
1316 type
= gfc_typenode_for_spec (&expr
->ts
);
1317 /* Initialize the result. */
1318 resvar
= gfc_create_var (type
, "test");
1320 tmp
= convert (type
, boolean_true_node
);
1322 tmp
= convert (type
, boolean_false_node
);
1323 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1325 /* Walk the arguments. */
1326 arrayss
= gfc_walk_expr (actual
->expr
);
1327 gcc_assert (arrayss
!= gfc_ss_terminator
);
1329 /* Initialize the scalarizer. */
1330 gfc_init_loopinfo (&loop
);
1331 exit_label
= gfc_build_label_decl (NULL_TREE
);
1332 TREE_USED (exit_label
) = 1;
1333 gfc_add_ss_to_loop (&loop
, arrayss
);
1335 /* Initialize the loop. */
1336 gfc_conv_ss_startstride (&loop
);
1337 gfc_conv_loop_setup (&loop
);
1339 gfc_mark_ss_chain_used (arrayss
, 1);
1340 /* Generate the loop body. */
1341 gfc_start_scalarized_body (&loop
, &body
);
1343 /* If the condition matches then set the return value. */
1344 gfc_start_block (&block
);
1346 tmp
= convert (type
, boolean_false_node
);
1348 tmp
= convert (type
, boolean_true_node
);
1349 gfc_add_modify_expr (&block
, resvar
, tmp
);
1351 /* And break out of the loop. */
1352 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1353 gfc_add_expr_to_block (&block
, tmp
);
1355 found
= gfc_finish_block (&block
);
1357 /* Check this element. */
1358 gfc_init_se (&arrayse
, NULL
);
1359 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1360 arrayse
.ss
= arrayss
;
1361 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1363 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1364 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
,
1365 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1366 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1367 gfc_add_expr_to_block (&body
, tmp
);
1368 gfc_add_block_to_block (&body
, &arrayse
.post
);
1370 gfc_trans_scalarizing_loops (&loop
, &body
);
1372 /* Add the exit label. */
1373 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1374 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1376 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1377 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1378 gfc_cleanup_loop (&loop
);
1383 /* COUNT(A) = Number of true elements in A. */
1385 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1392 gfc_actual_arglist
*actual
;
1398 gfc_conv_intrinsic_funcall (se
, expr
);
1402 actual
= expr
->value
.function
.actual
;
1404 type
= gfc_typenode_for_spec (&expr
->ts
);
1405 /* Initialize the result. */
1406 resvar
= gfc_create_var (type
, "count");
1407 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1409 /* Walk the arguments. */
1410 arrayss
= gfc_walk_expr (actual
->expr
);
1411 gcc_assert (arrayss
!= gfc_ss_terminator
);
1413 /* Initialize the scalarizer. */
1414 gfc_init_loopinfo (&loop
);
1415 gfc_add_ss_to_loop (&loop
, arrayss
);
1417 /* Initialize the loop. */
1418 gfc_conv_ss_startstride (&loop
);
1419 gfc_conv_loop_setup (&loop
);
1421 gfc_mark_ss_chain_used (arrayss
, 1);
1422 /* Generate the loop body. */
1423 gfc_start_scalarized_body (&loop
, &body
);
1425 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (resvar
), resvar
,
1426 build_int_cst (TREE_TYPE (resvar
), 1));
1427 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1429 gfc_init_se (&arrayse
, NULL
);
1430 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1431 arrayse
.ss
= arrayss
;
1432 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1433 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1435 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1436 gfc_add_expr_to_block (&body
, tmp
);
1437 gfc_add_block_to_block (&body
, &arrayse
.post
);
1439 gfc_trans_scalarizing_loops (&loop
, &body
);
1441 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1442 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1443 gfc_cleanup_loop (&loop
);
1448 /* Inline implementation of the sum and product intrinsics. */
1450 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1458 gfc_actual_arglist
*actual
;
1463 gfc_expr
*arrayexpr
;
1468 gfc_conv_intrinsic_funcall (se
, expr
);
1472 type
= gfc_typenode_for_spec (&expr
->ts
);
1473 /* Initialize the result. */
1474 resvar
= gfc_create_var (type
, "val");
1475 if (op
== PLUS_EXPR
)
1476 tmp
= gfc_build_const (type
, integer_zero_node
);
1478 tmp
= gfc_build_const (type
, integer_one_node
);
1480 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1482 /* Walk the arguments. */
1483 actual
= expr
->value
.function
.actual
;
1484 arrayexpr
= actual
->expr
;
1485 arrayss
= gfc_walk_expr (arrayexpr
);
1486 gcc_assert (arrayss
!= gfc_ss_terminator
);
1488 actual
= actual
->next
->next
;
1489 gcc_assert (actual
);
1490 maskexpr
= actual
->expr
;
1491 if (maskexpr
&& maskexpr
->rank
!= 0)
1493 maskss
= gfc_walk_expr (maskexpr
);
1494 gcc_assert (maskss
!= gfc_ss_terminator
);
1499 /* Initialize the scalarizer. */
1500 gfc_init_loopinfo (&loop
);
1501 gfc_add_ss_to_loop (&loop
, arrayss
);
1503 gfc_add_ss_to_loop (&loop
, maskss
);
1505 /* Initialize the loop. */
1506 gfc_conv_ss_startstride (&loop
);
1507 gfc_conv_loop_setup (&loop
);
1509 gfc_mark_ss_chain_used (arrayss
, 1);
1511 gfc_mark_ss_chain_used (maskss
, 1);
1512 /* Generate the loop body. */
1513 gfc_start_scalarized_body (&loop
, &body
);
1515 /* If we have a mask, only add this element if the mask is set. */
1518 gfc_init_se (&maskse
, NULL
);
1519 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1521 gfc_conv_expr_val (&maskse
, maskexpr
);
1522 gfc_add_block_to_block (&body
, &maskse
.pre
);
1524 gfc_start_block (&block
);
1527 gfc_init_block (&block
);
1529 /* Do the actual summation/product. */
1530 gfc_init_se (&arrayse
, NULL
);
1531 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1532 arrayse
.ss
= arrayss
;
1533 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1534 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1536 tmp
= build2 (op
, type
, resvar
, arrayse
.expr
);
1537 gfc_add_modify_expr (&block
, resvar
, tmp
);
1538 gfc_add_block_to_block (&block
, &arrayse
.post
);
1542 /* We enclose the above in if (mask) {...} . */
1543 tmp
= gfc_finish_block (&block
);
1545 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1548 tmp
= gfc_finish_block (&block
);
1549 gfc_add_expr_to_block (&body
, tmp
);
1551 gfc_trans_scalarizing_loops (&loop
, &body
);
1553 /* For a scalar mask, enclose the loop in an if statement. */
1554 if (maskexpr
&& maskss
== NULL
)
1556 gfc_init_se (&maskse
, NULL
);
1557 gfc_conv_expr_val (&maskse
, maskexpr
);
1558 gfc_init_block (&block
);
1559 gfc_add_block_to_block (&block
, &loop
.pre
);
1560 gfc_add_block_to_block (&block
, &loop
.post
);
1561 tmp
= gfc_finish_block (&block
);
1563 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1564 gfc_add_expr_to_block (&block
, tmp
);
1565 gfc_add_block_to_block (&se
->pre
, &block
);
1569 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1570 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1573 gfc_cleanup_loop (&loop
);
1579 /* Inline implementation of the dot_product intrinsic. This function
1580 is based on gfc_conv_intrinsic_arith (the previous function). */
1582 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1590 gfc_actual_arglist
*actual
;
1591 gfc_ss
*arrayss1
, *arrayss2
;
1592 gfc_se arrayse1
, arrayse2
;
1593 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1595 type
= gfc_typenode_for_spec (&expr
->ts
);
1597 /* Initialize the result. */
1598 resvar
= gfc_create_var (type
, "val");
1599 if (expr
->ts
.type
== BT_LOGICAL
)
1600 tmp
= convert (type
, integer_zero_node
);
1602 tmp
= gfc_build_const (type
, integer_zero_node
);
1604 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1606 /* Walk argument #1. */
1607 actual
= expr
->value
.function
.actual
;
1608 arrayexpr1
= actual
->expr
;
1609 arrayss1
= gfc_walk_expr (arrayexpr1
);
1610 gcc_assert (arrayss1
!= gfc_ss_terminator
);
1612 /* Walk argument #2. */
1613 actual
= actual
->next
;
1614 arrayexpr2
= actual
->expr
;
1615 arrayss2
= gfc_walk_expr (arrayexpr2
);
1616 gcc_assert (arrayss2
!= gfc_ss_terminator
);
1618 /* Initialize the scalarizer. */
1619 gfc_init_loopinfo (&loop
);
1620 gfc_add_ss_to_loop (&loop
, arrayss1
);
1621 gfc_add_ss_to_loop (&loop
, arrayss2
);
1623 /* Initialize the loop. */
1624 gfc_conv_ss_startstride (&loop
);
1625 gfc_conv_loop_setup (&loop
);
1627 gfc_mark_ss_chain_used (arrayss1
, 1);
1628 gfc_mark_ss_chain_used (arrayss2
, 1);
1630 /* Generate the loop body. */
1631 gfc_start_scalarized_body (&loop
, &body
);
1632 gfc_init_block (&block
);
1634 /* Make the tree expression for [conjg(]array1[)]. */
1635 gfc_init_se (&arrayse1
, NULL
);
1636 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
1637 arrayse1
.ss
= arrayss1
;
1638 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
1639 if (expr
->ts
.type
== BT_COMPLEX
)
1640 arrayse1
.expr
= build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
1641 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
1643 /* Make the tree expression for array2. */
1644 gfc_init_se (&arrayse2
, NULL
);
1645 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
1646 arrayse2
.ss
= arrayss2
;
1647 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
1648 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
1650 /* Do the actual product and sum. */
1651 if (expr
->ts
.type
== BT_LOGICAL
)
1653 tmp
= build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
1654 tmp
= build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
1658 tmp
= build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
1659 tmp
= build2 (PLUS_EXPR
, type
, resvar
, tmp
);
1661 gfc_add_modify_expr (&block
, resvar
, tmp
);
1663 /* Finish up the loop block and the loop. */
1664 tmp
= gfc_finish_block (&block
);
1665 gfc_add_expr_to_block (&body
, tmp
);
1667 gfc_trans_scalarizing_loops (&loop
, &body
);
1668 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1669 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1670 gfc_cleanup_loop (&loop
);
1677 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
1681 stmtblock_t ifblock
;
1682 stmtblock_t elseblock
;
1689 gfc_actual_arglist
*actual
;
1694 gfc_expr
*arrayexpr
;
1701 gfc_conv_intrinsic_funcall (se
, expr
);
1705 /* Initialize the result. */
1706 pos
= gfc_create_var (gfc_array_index_type
, "pos");
1707 type
= gfc_typenode_for_spec (&expr
->ts
);
1709 /* Walk the arguments. */
1710 actual
= expr
->value
.function
.actual
;
1711 arrayexpr
= actual
->expr
;
1712 arrayss
= gfc_walk_expr (arrayexpr
);
1713 gcc_assert (arrayss
!= gfc_ss_terminator
);
1715 actual
= actual
->next
->next
;
1716 gcc_assert (actual
);
1717 maskexpr
= actual
->expr
;
1718 if (maskexpr
&& maskexpr
->rank
!= 0)
1720 maskss
= gfc_walk_expr (maskexpr
);
1721 gcc_assert (maskss
!= gfc_ss_terminator
);
1726 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
1727 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
1728 switch (arrayexpr
->ts
.type
)
1731 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
1735 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
1736 arrayexpr
->ts
.kind
);
1743 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1745 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1746 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1748 /* Initialize the scalarizer. */
1749 gfc_init_loopinfo (&loop
);
1750 gfc_add_ss_to_loop (&loop
, arrayss
);
1752 gfc_add_ss_to_loop (&loop
, maskss
);
1754 /* Initialize the loop. */
1755 gfc_conv_ss_startstride (&loop
);
1756 gfc_conv_loop_setup (&loop
);
1758 gcc_assert (loop
.dimen
== 1);
1760 /* Initialize the position to zero, following Fortran 2003. We are free
1761 to do this because Fortran 95 allows the result of an entirely false
1762 mask to be processor dependent. */
1763 gfc_add_modify_expr (&loop
.pre
, pos
, gfc_index_zero_node
);
1765 gfc_mark_ss_chain_used (arrayss
, 1);
1767 gfc_mark_ss_chain_used (maskss
, 1);
1768 /* Generate the loop body. */
1769 gfc_start_scalarized_body (&loop
, &body
);
1771 /* If we have a mask, only check this element if the mask is set. */
1774 gfc_init_se (&maskse
, NULL
);
1775 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1777 gfc_conv_expr_val (&maskse
, maskexpr
);
1778 gfc_add_block_to_block (&body
, &maskse
.pre
);
1780 gfc_start_block (&block
);
1783 gfc_init_block (&block
);
1785 /* Compare with the current limit. */
1786 gfc_init_se (&arrayse
, NULL
);
1787 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1788 arrayse
.ss
= arrayss
;
1789 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1790 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1792 /* We do the following if this is a more extreme value. */
1793 gfc_start_block (&ifblock
);
1795 /* Assign the value to the limit... */
1796 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
1798 /* Remember where we are. */
1799 gfc_add_modify_expr (&ifblock
, pos
, loop
.loopvar
[0]);
1801 ifbody
= gfc_finish_block (&ifblock
);
1803 /* If it is a more extreme value or pos is still zero. */
1804 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
,
1805 build2 (op
, boolean_type_node
, arrayse
.expr
, limit
),
1806 build2 (EQ_EXPR
, boolean_type_node
, pos
, gfc_index_zero_node
));
1807 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1808 gfc_add_expr_to_block (&block
, tmp
);
1812 /* We enclose the above in if (mask) {...}. */
1813 tmp
= gfc_finish_block (&block
);
1815 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1818 tmp
= gfc_finish_block (&block
);
1819 gfc_add_expr_to_block (&body
, tmp
);
1821 gfc_trans_scalarizing_loops (&loop
, &body
);
1823 /* For a scalar mask, enclose the loop in an if statement. */
1824 if (maskexpr
&& maskss
== NULL
)
1826 gfc_init_se (&maskse
, NULL
);
1827 gfc_conv_expr_val (&maskse
, maskexpr
);
1828 gfc_init_block (&block
);
1829 gfc_add_block_to_block (&block
, &loop
.pre
);
1830 gfc_add_block_to_block (&block
, &loop
.post
);
1831 tmp
= gfc_finish_block (&block
);
1833 /* For the else part of the scalar mask, just initialize
1834 the pos variable the same way as above. */
1836 gfc_init_block (&elseblock
);
1837 gfc_add_modify_expr (&elseblock
, pos
, gfc_index_zero_node
);
1838 elsetmp
= gfc_finish_block (&elseblock
);
1840 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
1841 gfc_add_expr_to_block (&block
, tmp
);
1842 gfc_add_block_to_block (&se
->pre
, &block
);
1846 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1847 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1849 gfc_cleanup_loop (&loop
);
1851 /* Return a value in the range 1..SIZE(array). */
1852 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, loop
.from
[0],
1853 gfc_index_one_node
);
1854 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, pos
, tmp
);
1855 /* And convert to the required type. */
1856 se
->expr
= convert (type
, tmp
);
1860 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
1869 gfc_actual_arglist
*actual
;
1874 gfc_expr
*arrayexpr
;
1880 gfc_conv_intrinsic_funcall (se
, expr
);
1884 type
= gfc_typenode_for_spec (&expr
->ts
);
1885 /* Initialize the result. */
1886 limit
= gfc_create_var (type
, "limit");
1887 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
1888 switch (expr
->ts
.type
)
1891 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
1895 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
1902 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1904 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
1905 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
1907 /* Walk the arguments. */
1908 actual
= expr
->value
.function
.actual
;
1909 arrayexpr
= actual
->expr
;
1910 arrayss
= gfc_walk_expr (arrayexpr
);
1911 gcc_assert (arrayss
!= gfc_ss_terminator
);
1913 actual
= actual
->next
->next
;
1914 gcc_assert (actual
);
1915 maskexpr
= actual
->expr
;
1916 if (maskexpr
&& maskexpr
->rank
!= 0)
1918 maskss
= gfc_walk_expr (maskexpr
);
1919 gcc_assert (maskss
!= gfc_ss_terminator
);
1924 /* Initialize the scalarizer. */
1925 gfc_init_loopinfo (&loop
);
1926 gfc_add_ss_to_loop (&loop
, arrayss
);
1928 gfc_add_ss_to_loop (&loop
, maskss
);
1930 /* Initialize the loop. */
1931 gfc_conv_ss_startstride (&loop
);
1932 gfc_conv_loop_setup (&loop
);
1934 gfc_mark_ss_chain_used (arrayss
, 1);
1936 gfc_mark_ss_chain_used (maskss
, 1);
1937 /* Generate the loop body. */
1938 gfc_start_scalarized_body (&loop
, &body
);
1940 /* If we have a mask, only add this element if the mask is set. */
1943 gfc_init_se (&maskse
, NULL
);
1944 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1946 gfc_conv_expr_val (&maskse
, maskexpr
);
1947 gfc_add_block_to_block (&body
, &maskse
.pre
);
1949 gfc_start_block (&block
);
1952 gfc_init_block (&block
);
1954 /* Compare with the current limit. */
1955 gfc_init_se (&arrayse
, NULL
);
1956 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1957 arrayse
.ss
= arrayss
;
1958 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1959 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1961 /* Assign the value to the limit... */
1962 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
1964 /* If it is a more extreme value. */
1965 tmp
= build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
1966 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
1967 gfc_add_expr_to_block (&block
, tmp
);
1968 gfc_add_block_to_block (&block
, &arrayse
.post
);
1970 tmp
= gfc_finish_block (&block
);
1972 /* We enclose the above in if (mask) {...}. */
1973 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1974 gfc_add_expr_to_block (&body
, tmp
);
1976 gfc_trans_scalarizing_loops (&loop
, &body
);
1978 /* For a scalar mask, enclose the loop in an if statement. */
1979 if (maskexpr
&& maskss
== NULL
)
1981 gfc_init_se (&maskse
, NULL
);
1982 gfc_conv_expr_val (&maskse
, maskexpr
);
1983 gfc_init_block (&block
);
1984 gfc_add_block_to_block (&block
, &loop
.pre
);
1985 gfc_add_block_to_block (&block
, &loop
.post
);
1986 tmp
= gfc_finish_block (&block
);
1988 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1989 gfc_add_expr_to_block (&block
, tmp
);
1990 gfc_add_block_to_block (&se
->pre
, &block
);
1994 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1995 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1998 gfc_cleanup_loop (&loop
);
2003 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2005 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2012 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2013 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2014 arg
= TREE_VALUE (arg
);
2015 type
= TREE_TYPE (arg
);
2017 tmp
= build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
2018 tmp
= build2 (BIT_AND_EXPR
, type
, arg
, tmp
);
2019 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2020 build_int_cst (type
, 0));
2021 type
= gfc_typenode_for_spec (&expr
->ts
);
2022 se
->expr
= convert (type
, tmp
);
2025 /* Generate code to perform the specified operation. */
2027 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
2033 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2034 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2035 arg
= TREE_VALUE (arg
);
2036 type
= TREE_TYPE (arg
);
2038 se
->expr
= fold_build2 (op
, type
, arg
, arg2
);
2043 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2047 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2048 arg
= TREE_VALUE (arg
);
2050 se
->expr
= build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2053 /* Set or clear a single bit. */
2055 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2063 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2064 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2065 arg
= TREE_VALUE (arg
);
2066 type
= TREE_TYPE (arg
);
2068 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), arg2
);
2074 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2076 se
->expr
= fold_build2 (op
, type
, arg
, tmp
);
2079 /* Extract a sequence of bits.
2080 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2082 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2091 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2092 arg2
= TREE_CHAIN (arg
);
2093 arg3
= TREE_VALUE (TREE_CHAIN (arg2
));
2094 arg
= TREE_VALUE (arg
);
2095 arg2
= TREE_VALUE (arg2
);
2096 type
= TREE_TYPE (arg
);
2098 mask
= build_int_cst (NULL_TREE
, -1);
2099 mask
= build2 (LSHIFT_EXPR
, type
, mask
, arg3
);
2100 mask
= build1 (BIT_NOT_EXPR
, type
, mask
);
2102 tmp
= build2 (RSHIFT_EXPR
, type
, arg
, arg2
);
2104 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2107 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2109 : ((shift >= 0) ? i << shift : i >> -shift)
2110 where all shifts are logical shifts. */
2112 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2125 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2126 arg2
= TREE_VALUE (TREE_CHAIN (arg
));
2127 arg
= TREE_VALUE (arg
);
2128 type
= TREE_TYPE (arg
);
2129 utype
= gfc_unsigned_type (type
);
2131 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg2
), arg2
);
2133 /* Left shift if positive. */
2134 lshift
= fold_build2 (LSHIFT_EXPR
, type
, arg
, width
);
2136 /* Right shift if negative.
2137 We convert to an unsigned type because we want a logical shift.
2138 The standard doesn't define the case of shifting negative
2139 numbers, and we try to be compatible with other compilers, most
2140 notably g77, here. */
2141 rshift
= fold_convert (type
, build2 (RSHIFT_EXPR
, utype
,
2142 convert (utype
, arg
), width
));
2144 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, arg2
,
2145 build_int_cst (TREE_TYPE (arg2
), 0));
2146 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2148 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2149 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2151 num_bits
= build_int_cst (TREE_TYPE (arg2
), TYPE_PRECISION (type
));
2152 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2154 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2155 build_int_cst (type
, 0), tmp
);
2158 /* Circular shift. AKA rotate or barrel shift. */
2160 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2171 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2172 arg2
= TREE_CHAIN (arg
);
2173 arg3
= TREE_CHAIN (arg2
);
2176 /* Use a library function for the 3 parameter version. */
2177 tree int4type
= gfc_get_int_type (4);
2179 type
= TREE_TYPE (TREE_VALUE (arg
));
2180 /* We convert the first argument to at least 4 bytes, and
2181 convert back afterwards. This removes the need for library
2182 functions for all argument sizes, and function will be
2183 aligned to at least 32 bits, so there's no loss. */
2184 if (expr
->ts
.kind
< 4)
2186 tmp
= convert (int4type
, TREE_VALUE (arg
));
2187 TREE_VALUE (arg
) = tmp
;
2189 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2190 need loads of library functions. They cannot have values >
2191 BIT_SIZE (I) so the conversion is safe. */
2192 TREE_VALUE (arg2
) = convert (int4type
, TREE_VALUE (arg2
));
2193 TREE_VALUE (arg3
) = convert (int4type
, TREE_VALUE (arg3
));
2195 switch (expr
->ts
.kind
)
2200 tmp
= gfor_fndecl_math_ishftc4
;
2203 tmp
= gfor_fndecl_math_ishftc8
;
2206 tmp
= gfor_fndecl_math_ishftc16
;
2211 se
->expr
= build_function_call_expr (tmp
, arg
);
2212 /* Convert the result back to the original type, if we extended
2213 the first argument's width above. */
2214 if (expr
->ts
.kind
< 4)
2215 se
->expr
= convert (type
, se
->expr
);
2219 arg
= TREE_VALUE (arg
);
2220 arg2
= TREE_VALUE (arg2
);
2221 type
= TREE_TYPE (arg
);
2223 /* Rotate left if positive. */
2224 lrot
= fold_build2 (LROTATE_EXPR
, type
, arg
, arg2
);
2226 /* Rotate right if negative. */
2227 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (arg2
), arg2
);
2228 rrot
= fold_build2 (RROTATE_EXPR
, type
, arg
, tmp
);
2230 zero
= build_int_cst (TREE_TYPE (arg2
), 0);
2231 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg2
, zero
);
2232 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2234 /* Do nothing if shift == 0. */
2235 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg2
, zero
);
2236 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, arg
, rrot
);
2239 /* The length of a character string. */
2241 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2250 gcc_assert (!se
->ss
);
2252 arg
= expr
->value
.function
.actual
->expr
;
2254 type
= gfc_typenode_for_spec (&expr
->ts
);
2255 switch (arg
->expr_type
)
2258 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2262 if (arg
->expr_type
== EXPR_VARIABLE
2263 && (arg
->ref
== NULL
|| (arg
->ref
->next
== NULL
2264 && arg
->ref
->type
== REF_ARRAY
)))
2266 /* This doesn't catch all cases.
2267 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2268 and the surrounding thread. */
2269 sym
= arg
->symtree
->n
.sym
;
2270 decl
= gfc_get_symbol_decl (sym
);
2271 if (decl
== current_function_decl
&& sym
->attr
.function
2272 && (sym
->result
== sym
))
2273 decl
= gfc_get_fake_result_decl (sym
, 0);
2275 len
= sym
->ts
.cl
->backend_decl
;
2280 /* Anybody stupid enough to do this deserves inefficient code. */
2281 gfc_init_se (&argse
, se
);
2282 gfc_conv_expr (&argse
, arg
);
2283 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2284 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2285 len
= argse
.string_length
;
2289 se
->expr
= convert (type
, len
);
2292 /* The length of a character string not including trailing blanks. */
2294 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2299 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2300 type
= gfc_typenode_for_spec (&expr
->ts
);
2301 se
->expr
= build_function_call_expr (gfor_fndecl_string_len_trim
, args
);
2302 se
->expr
= convert (type
, se
->expr
);
2306 /* Returns the starting position of a substring within a string. */
2309 gfc_conv_intrinsic_index (gfc_se
* se
, gfc_expr
* expr
)
2311 tree logical4_type_node
= gfc_get_logical_type (4);
2317 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2318 type
= gfc_typenode_for_spec (&expr
->ts
);
2319 tmp
= gfc_advance_chain (args
, 3);
2320 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2322 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2324 TREE_CHAIN (tmp
) = back
;
2328 back
= TREE_CHAIN (tmp
);
2329 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2332 se
->expr
= build_function_call_expr (gfor_fndecl_string_index
, args
);
2333 se
->expr
= convert (type
, se
->expr
);
2336 /* The ascii value for a single character. */
2338 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2343 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2344 arg
= TREE_VALUE (TREE_CHAIN (arg
));
2345 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg
)));
2346 arg
= build1 (NOP_EXPR
, pchar_type_node
, arg
);
2347 type
= gfc_typenode_for_spec (&expr
->ts
);
2349 se
->expr
= build_fold_indirect_ref (arg
);
2350 se
->expr
= convert (type
, se
->expr
);
2354 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2357 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2366 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2367 if (expr
->ts
.type
!= BT_CHARACTER
)
2369 tsource
= TREE_VALUE (arg
);
2370 arg
= TREE_CHAIN (arg
);
2371 fsource
= TREE_VALUE (arg
);
2372 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2376 /* We do the same as in the non-character case, but the argument
2377 list is different because of the string length arguments. We
2378 also have to set the string length for the result. */
2379 len
= TREE_VALUE (arg
);
2380 arg
= TREE_CHAIN (arg
);
2381 tsource
= TREE_VALUE (arg
);
2382 arg
= TREE_CHAIN (TREE_CHAIN (arg
));
2383 fsource
= TREE_VALUE (arg
);
2384 mask
= TREE_VALUE (TREE_CHAIN (arg
));
2386 se
->string_length
= len
;
2388 type
= TREE_TYPE (tsource
);
2389 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2394 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
2396 gfc_actual_arglist
*actual
;
2403 gfc_init_se (&argse
, NULL
);
2404 actual
= expr
->value
.function
.actual
;
2406 ss
= gfc_walk_expr (actual
->expr
);
2407 gcc_assert (ss
!= gfc_ss_terminator
);
2408 argse
.want_pointer
= 1;
2409 argse
.data_not_needed
= 1;
2410 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
2411 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2412 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2413 args
= gfc_chainon_list (NULL_TREE
, argse
.expr
);
2415 actual
= actual
->next
;
2418 gfc_init_se (&argse
, NULL
);
2419 gfc_conv_expr_type (&argse
, actual
->expr
, gfc_array_index_type
);
2420 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2421 args
= gfc_chainon_list (args
, argse
.expr
);
2422 fndecl
= gfor_fndecl_size1
;
2425 fndecl
= gfor_fndecl_size0
;
2427 se
->expr
= build_function_call_expr (fndecl
, args
);
2428 type
= gfc_typenode_for_spec (&expr
->ts
);
2429 se
->expr
= convert (type
, se
->expr
);
2433 /* Intrinsic string comparison functions. */
2436 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
2442 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2443 arg2
= TREE_CHAIN (TREE_CHAIN (args
));
2445 se
->expr
= gfc_build_compare_string (TREE_VALUE (args
),
2446 TREE_VALUE (TREE_CHAIN (args
)), TREE_VALUE (arg2
),
2447 TREE_VALUE (TREE_CHAIN (arg2
)));
2449 type
= gfc_typenode_for_spec (&expr
->ts
);
2450 se
->expr
= fold_build2 (op
, type
, se
->expr
,
2451 build_int_cst (TREE_TYPE (se
->expr
), 0));
2454 /* Generate a call to the adjustl/adjustr library function. */
2456 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
2464 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2465 len
= TREE_VALUE (args
);
2467 type
= TREE_TYPE (TREE_VALUE (TREE_CHAIN (args
)));
2468 var
= gfc_conv_string_tmp (se
, type
, len
);
2469 args
= tree_cons (NULL_TREE
, var
, args
);
2471 tmp
= build_function_call_expr (fndecl
, args
);
2472 gfc_add_expr_to_block (&se
->pre
, tmp
);
2474 se
->string_length
= len
;
2478 /* Array transfer statement.
2479 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2481 typeof<DEST> = typeof<MOLD>
2483 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2484 sizeof (DEST(0) * SIZE). */
2487 gfc_conv_intrinsic_array_transfer (gfc_se
* se
, gfc_expr
* expr
)
2500 gfc_actual_arglist
*arg
;
2507 gcc_assert (se
->loop
);
2508 info
= &se
->ss
->data
.info
;
2510 /* Convert SOURCE. The output from this stage is:-
2511 source_bytes = length of the source in bytes
2512 source = pointer to the source data. */
2513 arg
= expr
->value
.function
.actual
;
2514 gfc_init_se (&argse
, NULL
);
2515 ss
= gfc_walk_expr (arg
->expr
);
2517 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
2519 /* Obtain the pointer to source and the length of source in bytes. */
2520 if (ss
== gfc_ss_terminator
)
2522 gfc_conv_expr_reference (&argse
, arg
->expr
);
2523 source
= argse
.expr
;
2525 /* Obtain the source word length. */
2526 tmp
= size_in_bytes(TREE_TYPE(TREE_TYPE (source
)));
2527 tmp
= fold_convert (gfc_array_index_type
, tmp
);
2531 gfc_init_se (&argse
, NULL
);
2532 argse
.want_pointer
= 0;
2533 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
2534 source
= gfc_conv_descriptor_data_get (argse
.expr
);
2536 /* Repack the source if not a full variable array. */
2537 if (!(arg
->expr
->expr_type
== EXPR_VARIABLE
2538 && arg
->expr
->ref
->u
.ar
.type
== AR_FULL
))
2540 tmp
= build_fold_addr_expr (argse
.expr
);
2541 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
2542 source
= build_function_call_expr (gfor_fndecl_in_pack
, tmp
);
2543 source
= gfc_evaluate_now (source
, &argse
.pre
);
2545 /* Free the temporary. */
2546 gfc_start_block (&block
);
2547 tmp
= convert (pvoid_type_node
, source
);
2548 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
2549 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
2550 gfc_add_expr_to_block (&block
, tmp
);
2551 stmt
= gfc_finish_block (&block
);
2553 /* Clean up if it was repacked. */
2554 gfc_init_block (&block
);
2555 tmp
= gfc_conv_array_data (argse
.expr
);
2556 tmp
= build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
2557 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
2558 gfc_add_expr_to_block (&block
, tmp
);
2559 gfc_add_block_to_block (&block
, &se
->post
);
2560 gfc_init_block (&se
->post
);
2561 gfc_add_block_to_block (&se
->post
, &block
);
2564 /* Obtain the source word length. */
2565 tmp
= gfc_get_element_type (TREE_TYPE(argse
.expr
));
2566 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
2568 /* Obtain the size of the array in bytes. */
2569 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
2570 for (n
= 0; n
< arg
->expr
->rank
; n
++)
2573 idx
= gfc_rank_cst
[n
];
2574 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2575 stride
= gfc_conv_descriptor_stride (argse
.expr
, idx
);
2576 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
2577 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
2578 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2580 gfc_add_modify_expr (&argse
.pre
, extent
, tmp
);
2581 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2582 extent
, gfc_index_one_node
);
2583 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
,
2588 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
2589 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2590 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2592 /* Now convert MOLD. The sole output is:
2593 dest_word_len = destination word length in bytes. */
2596 gfc_init_se (&argse
, NULL
);
2597 ss
= gfc_walk_expr (arg
->expr
);
2599 if (ss
== gfc_ss_terminator
)
2601 gfc_conv_expr_reference (&argse
, arg
->expr
);
2602 tmp
= TREE_TYPE(TREE_TYPE (argse
.expr
));
2603 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes(tmp
));
2607 gfc_init_se (&argse
, NULL
);
2608 argse
.want_pointer
= 0;
2609 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
2610 tmp
= gfc_get_element_type (TREE_TYPE(argse
.expr
));
2611 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
2614 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
2615 gfc_add_modify_expr (&se
->pre
, dest_word_len
, tmp
);
2617 /* Finally convert SIZE, if it is present. */
2619 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
2623 gfc_init_se (&argse
, NULL
);
2624 gfc_conv_expr_reference (&argse
, arg
->expr
);
2625 tmp
= convert (gfc_array_index_type
,
2626 build_fold_indirect_ref (argse
.expr
));
2627 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2628 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2633 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
2634 if (tmp
!= NULL_TREE
)
2636 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
,
2637 tmp
, dest_word_len
);
2638 tmp
= build2 (MIN_EXPR
, gfc_array_index_type
, tmp
, source_bytes
);
2643 gfc_add_modify_expr (&se
->pre
, size_bytes
, tmp
);
2644 gfc_add_modify_expr (&se
->pre
, size_words
,
2645 build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
2646 size_bytes
, dest_word_len
));
2648 /* Evaluate the bounds of the result. If the loop range exists, we have
2649 to check if it is too large. If so, we modify loop->to be consistent
2650 with min(size, size(source)). Otherwise, size is made consistent with
2651 the loop range, so that the right number of bytes is transferred.*/
2652 n
= se
->loop
->order
[0];
2653 if (se
->loop
->to
[n
] != NULL_TREE
)
2655 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2656 se
->loop
->to
[n
], se
->loop
->from
[n
]);
2657 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2658 tmp
, gfc_index_one_node
);
2659 tmp
= build2 (MIN_EXPR
, gfc_array_index_type
,
2661 gfc_add_modify_expr (&se
->pre
, size_words
, tmp
);
2662 gfc_add_modify_expr (&se
->pre
, size_bytes
,
2663 build2 (MULT_EXPR
, gfc_array_index_type
,
2664 size_words
, dest_word_len
));
2665 upper
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2666 size_words
, se
->loop
->from
[n
]);
2667 upper
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2668 upper
, gfc_index_one_node
);
2672 upper
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2673 size_words
, gfc_index_one_node
);
2674 se
->loop
->from
[n
] = gfc_index_zero_node
;
2677 se
->loop
->to
[n
] = upper
;
2679 /* Build a destination descriptor, using the pointer, source, as the
2680 data field. This is already allocated so set callee_alloc. */
2681 tmp
= gfc_typenode_for_spec (&expr
->ts
);
2682 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
2683 info
, tmp
, false, false, true);
2685 tmp
= fold_convert (pvoid_type_node
, source
);
2686 gfc_conv_descriptor_data_set (&se
->pre
, info
->descriptor
, tmp
);
2687 se
->expr
= info
->descriptor
;
2688 if (expr
->ts
.type
== BT_CHARACTER
)
2689 se
->string_length
= dest_word_len
;
2693 /* Scalar transfer statement.
2694 TRANSFER (source, mold) = *(typeof<mold> *)&source. */
2697 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
2699 gfc_actual_arglist
*arg
;
2705 /* Get a pointer to the source. */
2706 arg
= expr
->value
.function
.actual
;
2707 ss
= gfc_walk_expr (arg
->expr
);
2708 gfc_init_se (&argse
, NULL
);
2709 if (ss
== gfc_ss_terminator
)
2710 gfc_conv_expr_reference (&argse
, arg
->expr
);
2712 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
2713 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2714 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2718 type
= gfc_typenode_for_spec (&expr
->ts
);
2719 ptr
= convert (build_pointer_type (type
), ptr
);
2720 if (expr
->ts
.type
== BT_CHARACTER
)
2722 gfc_init_se (&argse
, NULL
);
2723 gfc_conv_expr (&argse
, arg
->expr
);
2724 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2725 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2727 se
->string_length
= argse
.string_length
;
2731 se
->expr
= build_fold_indirect_ref (ptr
);
2736 /* Generate code for the ALLOCATED intrinsic.
2737 Generate inline code that directly check the address of the argument. */
2740 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
2742 gfc_actual_arglist
*arg1
;
2747 gfc_init_se (&arg1se
, NULL
);
2748 arg1
= expr
->value
.function
.actual
;
2749 ss1
= gfc_walk_expr (arg1
->expr
);
2750 arg1se
.descriptor_only
= 1;
2751 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2753 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
2754 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
2755 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2756 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
2760 /* Generate code for the ASSOCIATED intrinsic.
2761 If both POINTER and TARGET are arrays, generate a call to library function
2762 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2763 In other cases, generate inline code that directly compare the address of
2764 POINTER with the address of TARGET. */
2767 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
2769 gfc_actual_arglist
*arg1
;
2770 gfc_actual_arglist
*arg2
;
2778 gfc_init_se (&arg1se
, NULL
);
2779 gfc_init_se (&arg2se
, NULL
);
2780 arg1
= expr
->value
.function
.actual
;
2782 ss1
= gfc_walk_expr (arg1
->expr
);
2786 /* No optional target. */
2787 if (ss1
== gfc_ss_terminator
)
2789 /* A pointer to a scalar. */
2790 arg1se
.want_pointer
= 1;
2791 gfc_conv_expr (&arg1se
, arg1
->expr
);
2796 /* A pointer to an array. */
2797 arg1se
.descriptor_only
= 1;
2798 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
2799 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
2801 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp2
,
2802 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
2807 /* An optional target. */
2808 ss2
= gfc_walk_expr (arg2
->expr
);
2809 if (ss1
== gfc_ss_terminator
)
2811 /* A pointer to a scalar. */
2812 gcc_assert (ss2
== gfc_ss_terminator
);
2813 arg1se
.want_pointer
= 1;
2814 gfc_conv_expr (&arg1se
, arg1
->expr
);
2815 arg2se
.want_pointer
= 1;
2816 gfc_conv_expr (&arg2se
, arg2
->expr
);
2817 tmp
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
, arg2se
.expr
);
2822 /* A pointer to an array, call library function _gfor_associated. */
2823 gcc_assert (ss2
!= gfc_ss_terminator
);
2825 arg1se
.want_pointer
= 1;
2826 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
2827 args
= gfc_chainon_list (args
, arg1se
.expr
);
2828 arg2se
.want_pointer
= 1;
2829 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
2830 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2831 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2832 args
= gfc_chainon_list (args
, arg2se
.expr
);
2833 fndecl
= gfor_fndecl_associated
;
2834 se
->expr
= build_function_call_expr (fndecl
, args
);
2837 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2841 /* Scan a string for any one of the characters in a set of characters. */
2844 gfc_conv_intrinsic_scan (gfc_se
* se
, gfc_expr
* expr
)
2846 tree logical4_type_node
= gfc_get_logical_type (4);
2852 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2853 type
= gfc_typenode_for_spec (&expr
->ts
);
2854 tmp
= gfc_advance_chain (args
, 3);
2855 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2857 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2859 TREE_CHAIN (tmp
) = back
;
2863 back
= TREE_CHAIN (tmp
);
2864 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2867 se
->expr
= build_function_call_expr (gfor_fndecl_string_scan
, args
);
2868 se
->expr
= convert (type
, se
->expr
);
2872 /* Verify that a set of characters contains all the characters in a string
2873 by identifying the position of the first character in a string of
2874 characters that does not appear in a given set of characters. */
2877 gfc_conv_intrinsic_verify (gfc_se
* se
, gfc_expr
* expr
)
2879 tree logical4_type_node
= gfc_get_logical_type (4);
2885 args
= gfc_conv_intrinsic_function_args (se
, expr
);
2886 type
= gfc_typenode_for_spec (&expr
->ts
);
2887 tmp
= gfc_advance_chain (args
, 3);
2888 if (TREE_CHAIN (tmp
) == NULL_TREE
)
2890 back
= tree_cons (NULL_TREE
, build_int_cst (logical4_type_node
, 0),
2892 TREE_CHAIN (tmp
) = back
;
2896 back
= TREE_CHAIN (tmp
);
2897 TREE_VALUE (back
) = convert (logical4_type_node
, TREE_VALUE (back
));
2900 se
->expr
= build_function_call_expr (gfor_fndecl_string_verify
, args
);
2901 se
->expr
= convert (type
, se
->expr
);
2904 /* Prepare components and related information of a real number which is
2905 the first argument of a elemental functions to manipulate reals. */
2908 prepare_arg_info (gfc_se
* se
, gfc_expr
* expr
,
2909 real_compnt_info
* rcs
, int all
)
2916 tree exponent
, fraction
;
2920 if (TARGET_FLOAT_FORMAT
!= IEEE_FLOAT_FORMAT
)
2921 gfc_todo_error ("Non-IEEE floating format");
2923 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
);
2925 arg
= gfc_conv_intrinsic_function_args (se
, expr
);
2926 arg
= TREE_VALUE (arg
);
2927 rcs
->type
= TREE_TYPE (arg
);
2929 /* Force arg'type to integer by unaffected convert */
2930 a1
= expr
->value
.function
.actual
->expr
;
2931 masktype
= gfc_get_int_type (a1
->ts
.kind
);
2932 rcs
->mtype
= masktype
;
2933 tmp
= build1 (VIEW_CONVERT_EXPR
, masktype
, arg
);
2934 arg
= gfc_create_var (masktype
, "arg");
2935 gfc_add_modify_expr(&se
->pre
, arg
, tmp
);
2938 /* Calculate the numbers of bits of exponent, fraction and word */
2939 n
= gfc_validate_kind (a1
->ts
.type
, a1
->ts
.kind
, false);
2940 tmp
= build_int_cst (NULL_TREE
, gfc_real_kinds
[n
].digits
- 1);
2941 rcs
->fdigits
= convert (masktype
, tmp
);
2942 wbits
= build_int_cst (NULL_TREE
, TYPE_PRECISION (rcs
->type
) - 1);
2943 wbits
= convert (masktype
, wbits
);
2944 rcs
->edigits
= fold_build2 (MINUS_EXPR
, masktype
, wbits
, tmp
);
2946 /* Form masks for exponent/fraction/sign */
2947 one
= gfc_build_const (masktype
, integer_one_node
);
2948 rcs
->smask
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, wbits
);
2949 rcs
->f1
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, rcs
->fdigits
);
2950 rcs
->emask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->smask
, rcs
->f1
);
2951 rcs
->fmask
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->f1
, one
);
2953 tmp
= fold_build2 (MINUS_EXPR
, masktype
, rcs
->edigits
, one
);
2954 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, one
, tmp
);
2955 rcs
->bias
= fold_build2 (MINUS_EXPR
, masktype
, tmp
,one
);
2959 /* exponent, and fraction */
2960 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->emask
);
2961 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, rcs
->fdigits
);
2962 exponent
= gfc_create_var (masktype
, "exponent");
2963 gfc_add_modify_expr(&se
->pre
, exponent
, tmp
);
2964 rcs
->expn
= exponent
;
2966 tmp
= build2 (BIT_AND_EXPR
, masktype
, arg
, rcs
->fmask
);
2967 fraction
= gfc_create_var (masktype
, "fraction");
2968 gfc_add_modify_expr(&se
->pre
, fraction
, tmp
);
2969 rcs
->frac
= fraction
;
2973 /* Build a call to __builtin_clz. */
2976 call_builtin_clz (tree result_type
, tree op0
)
2978 tree fn
, parms
, call
;
2979 enum machine_mode op0_mode
= TYPE_MODE (TREE_TYPE (op0
));
2981 if (op0_mode
== TYPE_MODE (integer_type_node
))
2982 fn
= built_in_decls
[BUILT_IN_CLZ
];
2983 else if (op0_mode
== TYPE_MODE (long_integer_type_node
))
2984 fn
= built_in_decls
[BUILT_IN_CLZL
];
2985 else if (op0_mode
== TYPE_MODE (long_long_integer_type_node
))
2986 fn
= built_in_decls
[BUILT_IN_CLZLL
];
2990 parms
= tree_cons (NULL
, op0
, NULL
);
2991 call
= build_function_call_expr (fn
, parms
);
2993 return convert (result_type
, call
);
2997 /* Generate code for SPACING (X) intrinsic function.
2998 SPACING (X) = POW (2, e-p)
3002 t = expn - fdigits // e - p.
3003 res = t << fdigits // Form the exponent. Fraction is zero.
3004 if (t < 0) // The result is out of range. Denormalized case.
3009 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
3016 real_compnt_info rcs
;
3018 prepare_arg_info (se
, expr
, &rcs
, 0);
3020 masktype
= rcs
.mtype
;
3021 fdigits
= rcs
.fdigits
;
3023 zero
= gfc_build_const (masktype
, integer_zero_node
);
3024 tmp
= build2 (BIT_AND_EXPR
, masktype
, rcs
.emask
, arg
);
3025 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, fdigits
);
3026 tmp
= build2 (MINUS_EXPR
, masktype
, tmp
, fdigits
);
3027 cond
= build2 (LE_EXPR
, boolean_type_node
, tmp
, zero
);
3028 t1
= build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
3029 tmp
= build3 (COND_EXPR
, masktype
, cond
, tiny
, t1
);
3030 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
3035 /* Generate code for RRSPACING (X) intrinsic function.
3036 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
3038 So the result's exponent is p. And if X is normalized, X's fraction part
3039 is the result's fraction. If X is denormalized, to get the X's fraction we
3040 shift X's fraction part to left until the first '1' is removed.
3044 if (expn == 0 && frac == 0)
3048 // edigits is the number of exponent bits. Add the sign bit.
3049 sedigits = edigits + 1;
3051 if (expn == 0) // Denormalized case.
3053 t1 = leadzero (frac);
3054 frac = frac << (t1 + 1); //Remove the first '1'.
3055 frac = frac >> (sedigits); //Form the fraction.
3058 //fdigits is the number of fraction bits. Form the exponent.
3061 res = (t << fdigits) | frac;
3066 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
3069 tree tmp
, t1
, t2
, cond
, cond2
;
3071 tree fdigits
, fraction
;
3072 real_compnt_info rcs
;
3074 prepare_arg_info (se
, expr
, &rcs
, 1);
3075 masktype
= rcs
.mtype
;
3076 fdigits
= rcs
.fdigits
;
3077 fraction
= rcs
.frac
;
3078 one
= gfc_build_const (masktype
, integer_one_node
);
3079 zero
= gfc_build_const (masktype
, integer_zero_node
);
3080 t2
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.edigits
, one
);
3082 t1
= call_builtin_clz (masktype
, fraction
);
3083 tmp
= build2 (PLUS_EXPR
, masktype
, t1
, one
);
3084 tmp
= build2 (LSHIFT_EXPR
, masktype
, fraction
, tmp
);
3085 tmp
= build2 (RSHIFT_EXPR
, masktype
, tmp
, t2
);
3086 cond
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.expn
, zero
);
3087 fraction
= build3 (COND_EXPR
, masktype
, cond
, tmp
, fraction
);
3089 tmp
= fold_build2 (PLUS_EXPR
, masktype
, rcs
.bias
, fdigits
);
3090 tmp
= fold_build2 (LSHIFT_EXPR
, masktype
, tmp
, fdigits
);
3091 tmp
= build2 (BIT_IOR_EXPR
, masktype
, tmp
, fraction
);
3093 cond2
= build2 (EQ_EXPR
, boolean_type_node
, rcs
.frac
, zero
);
3094 cond
= build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
, cond
, cond2
);
3095 tmp
= build3 (COND_EXPR
, masktype
, cond
,
3096 build_int_cst (masktype
, 0), tmp
);
3098 tmp
= build1 (VIEW_CONVERT_EXPR
, rcs
.type
, tmp
);
3102 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3105 gfc_conv_intrinsic_si_kind (gfc_se
* se
, gfc_expr
* expr
)
3109 args
= gfc_conv_intrinsic_function_args (se
, expr
);
3110 args
= TREE_VALUE (args
);
3111 args
= build_fold_addr_expr (args
);
3112 args
= tree_cons (NULL_TREE
, args
, NULL_TREE
);
3113 se
->expr
= build_function_call_expr (gfor_fndecl_si_kind
, args
);
3116 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3119 gfc_conv_intrinsic_sr_kind (gfc_se
* se
, gfc_expr
* expr
)
3121 gfc_actual_arglist
*actual
;
3126 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3128 gfc_init_se (&argse
, se
);
3130 /* Pass a NULL pointer for an absent arg. */
3131 if (actual
->expr
== NULL
)
3132 argse
.expr
= null_pointer_node
;
3134 gfc_conv_expr_reference (&argse
, actual
->expr
);
3136 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3137 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3138 args
= gfc_chainon_list (args
, argse
.expr
);
3140 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
3144 /* Generate code for TRIM (A) intrinsic function. */
3147 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
3149 tree gfc_int4_type_node
= gfc_get_int_type (4);
3158 arglist
= NULL_TREE
;
3160 type
= build_pointer_type (gfc_character1_type_node
);
3161 var
= gfc_create_var (type
, "pstr");
3162 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
3163 len
= gfc_create_var (gfc_int4_type_node
, "len");
3165 tmp
= gfc_conv_intrinsic_function_args (se
, expr
);
3166 arglist
= gfc_chainon_list (arglist
, build_fold_addr_expr (len
));
3167 arglist
= gfc_chainon_list (arglist
, addr
);
3168 arglist
= chainon (arglist
, tmp
);
3170 tmp
= build_function_call_expr (gfor_fndecl_string_trim
, arglist
);
3171 gfc_add_expr_to_block (&se
->pre
, tmp
);
3173 /* Free the temporary afterwards, if necessary. */
3174 cond
= build2 (GT_EXPR
, boolean_type_node
, len
,
3175 build_int_cst (TREE_TYPE (len
), 0));
3176 arglist
= gfc_chainon_list (NULL_TREE
, var
);
3177 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, arglist
);
3178 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
3179 gfc_add_expr_to_block (&se
->post
, tmp
);
3182 se
->string_length
= len
;
3186 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3189 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
3191 tree gfc_int4_type_node
= gfc_get_int_type (4);
3200 args
= gfc_conv_intrinsic_function_args (se
, expr
);
3201 len
= TREE_VALUE (args
);
3202 tmp
= gfc_advance_chain (args
, 2);
3203 ncopies
= TREE_VALUE (tmp
);
3204 len
= fold_build2 (MULT_EXPR
, gfc_int4_type_node
, len
, ncopies
);
3205 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
3206 var
= gfc_conv_string_tmp (se
, build_pointer_type (type
), len
);
3208 arglist
= NULL_TREE
;
3209 arglist
= gfc_chainon_list (arglist
, var
);
3210 arglist
= chainon (arglist
, args
);
3211 tmp
= build_function_call_expr (gfor_fndecl_string_repeat
, arglist
);
3212 gfc_add_expr_to_block (&se
->pre
, tmp
);
3215 se
->string_length
= len
;
3219 /* Generate code for the IARGC intrinsic. */
3222 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
3228 /* Call the library function. This always returns an INTEGER(4). */
3229 fndecl
= gfor_fndecl_iargc
;
3230 tmp
= build_function_call_expr (fndecl
, NULL_TREE
);
3232 /* Convert it to the required type. */
3233 type
= gfc_typenode_for_spec (&expr
->ts
);
3234 tmp
= fold_convert (type
, tmp
);
3240 /* The loc intrinsic returns the address of its argument as
3241 gfc_index_integer_kind integer. */
3244 gfc_conv_intrinsic_loc(gfc_se
* se
, gfc_expr
* expr
)
3250 gcc_assert (!se
->ss
);
3252 arg_expr
= expr
->value
.function
.actual
->expr
;
3253 ss
= gfc_walk_expr (arg_expr
);
3254 if (ss
== gfc_ss_terminator
)
3255 gfc_conv_expr_reference (se
, arg_expr
);
3257 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1);
3258 se
->expr
= convert (gfc_unsigned_type (long_integer_type_node
),
3261 /* Create a temporary variable for loc return value. Without this,
3262 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
3263 temp_var
= gfc_create_var (gfc_unsigned_type (long_integer_type_node
),
3265 gfc_add_modify_expr (&se
->pre
, temp_var
, se
->expr
);
3266 se
->expr
= temp_var
;
3269 /* Generate code for an intrinsic function. Some map directly to library
3270 calls, others get special handling. In some cases the name of the function
3271 used depends on the type specifiers. */
3274 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
3276 gfc_intrinsic_sym
*isym
;
3280 isym
= expr
->value
.function
.isym
;
3282 name
= &expr
->value
.function
.name
[2];
3284 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
3286 lib
= gfc_is_intrinsic_libcall (expr
);
3290 se
->ignore_optional
= 1;
3291 gfc_conv_intrinsic_funcall (se
, expr
);
3296 switch (expr
->value
.function
.isym
->generic_id
)
3301 case GFC_ISYM_REPEAT
:
3302 gfc_conv_intrinsic_repeat (se
, expr
);
3306 gfc_conv_intrinsic_trim (se
, expr
);
3309 case GFC_ISYM_SI_KIND
:
3310 gfc_conv_intrinsic_si_kind (se
, expr
);
3313 case GFC_ISYM_SR_KIND
:
3314 gfc_conv_intrinsic_sr_kind (se
, expr
);
3317 case GFC_ISYM_EXPONENT
:
3318 gfc_conv_intrinsic_exponent (se
, expr
);
3321 case GFC_ISYM_SPACING
:
3322 gfc_conv_intrinsic_spacing (se
, expr
);
3325 case GFC_ISYM_RRSPACING
:
3326 gfc_conv_intrinsic_rrspacing (se
, expr
);
3330 gfc_conv_intrinsic_scan (se
, expr
);
3333 case GFC_ISYM_VERIFY
:
3334 gfc_conv_intrinsic_verify (se
, expr
);
3337 case GFC_ISYM_ALLOCATED
:
3338 gfc_conv_allocated (se
, expr
);
3341 case GFC_ISYM_ASSOCIATED
:
3342 gfc_conv_associated(se
, expr
);
3346 gfc_conv_intrinsic_abs (se
, expr
);
3349 case GFC_ISYM_ADJUSTL
:
3350 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustl
);
3353 case GFC_ISYM_ADJUSTR
:
3354 gfc_conv_intrinsic_adjust (se
, expr
, gfor_fndecl_adjustr
);
3357 case GFC_ISYM_AIMAG
:
3358 gfc_conv_intrinsic_imagpart (se
, expr
);
3362 gfc_conv_intrinsic_aint (se
, expr
, FIX_TRUNC_EXPR
);
3366 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
3369 case GFC_ISYM_ANINT
:
3370 gfc_conv_intrinsic_aint (se
, expr
, FIX_ROUND_EXPR
);
3374 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3378 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
3381 case GFC_ISYM_BTEST
:
3382 gfc_conv_intrinsic_btest (se
, expr
);
3385 case GFC_ISYM_ACHAR
:
3387 gfc_conv_intrinsic_char (se
, expr
);
3390 case GFC_ISYM_CONVERSION
:
3392 case GFC_ISYM_LOGICAL
:
3394 gfc_conv_intrinsic_conversion (se
, expr
);
3397 /* Integer conversions are handled separately to make sure we get the
3398 correct rounding mode. */
3400 gfc_conv_intrinsic_int (se
, expr
, FIX_TRUNC_EXPR
);
3404 gfc_conv_intrinsic_int (se
, expr
, FIX_ROUND_EXPR
);
3407 case GFC_ISYM_CEILING
:
3408 gfc_conv_intrinsic_int (se
, expr
, FIX_CEIL_EXPR
);
3411 case GFC_ISYM_FLOOR
:
3412 gfc_conv_intrinsic_int (se
, expr
, FIX_FLOOR_EXPR
);
3416 gfc_conv_intrinsic_mod (se
, expr
, 0);
3419 case GFC_ISYM_MODULO
:
3420 gfc_conv_intrinsic_mod (se
, expr
, 1);
3423 case GFC_ISYM_CMPLX
:
3424 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
3427 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
3428 gfc_conv_intrinsic_iargc (se
, expr
);
3431 case GFC_ISYM_COMPLEX
:
3432 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
3435 case GFC_ISYM_CONJG
:
3436 gfc_conv_intrinsic_conjg (se
, expr
);
3439 case GFC_ISYM_COUNT
:
3440 gfc_conv_intrinsic_count (se
, expr
);
3443 case GFC_ISYM_CTIME
:
3444 gfc_conv_intrinsic_ctime (se
, expr
);
3448 gfc_conv_intrinsic_dim (se
, expr
);
3451 case GFC_ISYM_DOT_PRODUCT
:
3452 gfc_conv_intrinsic_dot_product (se
, expr
);
3455 case GFC_ISYM_DPROD
:
3456 gfc_conv_intrinsic_dprod (se
, expr
);
3459 case GFC_ISYM_FDATE
:
3460 gfc_conv_intrinsic_fdate (se
, expr
);
3464 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
3467 case GFC_ISYM_IBCLR
:
3468 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
3471 case GFC_ISYM_IBITS
:
3472 gfc_conv_intrinsic_ibits (se
, expr
);
3475 case GFC_ISYM_IBSET
:
3476 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
3479 case GFC_ISYM_IACHAR
:
3480 case GFC_ISYM_ICHAR
:
3481 /* We assume ASCII character sequence. */
3482 gfc_conv_intrinsic_ichar (se
, expr
);
3485 case GFC_ISYM_IARGC
:
3486 gfc_conv_intrinsic_iargc (se
, expr
);
3490 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3493 case GFC_ISYM_INDEX
:
3494 gfc_conv_intrinsic_index (se
, expr
);
3498 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3501 case GFC_ISYM_ISHFT
:
3502 gfc_conv_intrinsic_ishft (se
, expr
);
3505 case GFC_ISYM_ISHFTC
:
3506 gfc_conv_intrinsic_ishftc (se
, expr
);
3509 case GFC_ISYM_LBOUND
:
3510 gfc_conv_intrinsic_bound (se
, expr
, 0);
3513 case GFC_ISYM_TRANSPOSE
:
3514 if (se
->ss
&& se
->ss
->useflags
)
3516 gfc_conv_tmp_array_ref (se
);
3517 gfc_advance_se_ss_chain (se
);
3520 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
3524 gfc_conv_intrinsic_len (se
, expr
);
3527 case GFC_ISYM_LEN_TRIM
:
3528 gfc_conv_intrinsic_len_trim (se
, expr
);
3532 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
3536 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
3540 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
3544 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
3548 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
3551 case GFC_ISYM_MAXLOC
:
3552 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
3555 case GFC_ISYM_MAXVAL
:
3556 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
3559 case GFC_ISYM_MERGE
:
3560 gfc_conv_intrinsic_merge (se
, expr
);
3564 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
3567 case GFC_ISYM_MINLOC
:
3568 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
3571 case GFC_ISYM_MINVAL
:
3572 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
3576 gfc_conv_intrinsic_not (se
, expr
);
3580 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
3583 case GFC_ISYM_PRESENT
:
3584 gfc_conv_intrinsic_present (se
, expr
);
3587 case GFC_ISYM_PRODUCT
:
3588 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
3592 gfc_conv_intrinsic_sign (se
, expr
);
3596 gfc_conv_intrinsic_size (se
, expr
);
3600 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
3603 case GFC_ISYM_TRANSFER
:
3606 if (se
->ss
->useflags
)
3608 /* Access the previously obtained result. */
3609 gfc_conv_tmp_array_ref (se
);
3610 gfc_advance_se_ss_chain (se
);
3614 gfc_conv_intrinsic_array_transfer (se
, expr
);
3617 gfc_conv_intrinsic_transfer (se
, expr
);
3620 case GFC_ISYM_TTYNAM
:
3621 gfc_conv_intrinsic_ttynam (se
, expr
);
3624 case GFC_ISYM_UBOUND
:
3625 gfc_conv_intrinsic_bound (se
, expr
, 1);
3629 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
3633 gfc_conv_intrinsic_loc (se
, expr
);
3636 case GFC_ISYM_CHDIR
:
3637 case GFC_ISYM_ETIME
:
3639 case GFC_ISYM_FGETC
:
3642 case GFC_ISYM_FPUTC
:
3643 case GFC_ISYM_FSTAT
:
3644 case GFC_ISYM_FTELL
:
3645 case GFC_ISYM_GETCWD
:
3646 case GFC_ISYM_GETGID
:
3647 case GFC_ISYM_GETPID
:
3648 case GFC_ISYM_GETUID
:
3649 case GFC_ISYM_HOSTNM
:
3651 case GFC_ISYM_IERRNO
:
3652 case GFC_ISYM_IRAND
:
3653 case GFC_ISYM_ISATTY
:
3655 case GFC_ISYM_MALLOC
:
3656 case GFC_ISYM_MATMUL
:
3658 case GFC_ISYM_RENAME
:
3659 case GFC_ISYM_SECOND
:
3660 case GFC_ISYM_SECNDS
:
3661 case GFC_ISYM_SIGNAL
:
3663 case GFC_ISYM_SYMLNK
:
3664 case GFC_ISYM_SYSTEM
:
3666 case GFC_ISYM_TIME8
:
3667 case GFC_ISYM_UMASK
:
3668 case GFC_ISYM_UNLINK
:
3669 gfc_conv_intrinsic_funcall (se
, expr
);
3673 gfc_conv_intrinsic_lib_function (se
, expr
);
3679 /* This generates code to execute before entering the scalarization loop.
3680 Currently does nothing. */
3683 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
3685 switch (ss
->expr
->value
.function
.isym
->generic_id
)
3687 case GFC_ISYM_UBOUND
:
3688 case GFC_ISYM_LBOUND
:
3697 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3698 inside the scalarization loop. */
3701 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
3705 /* The two argument version returns a scalar. */
3706 if (expr
->value
.function
.actual
->next
->expr
)
3709 newss
= gfc_get_ss ();
3710 newss
->type
= GFC_SS_INTRINSIC
;
3718 /* Walk an intrinsic array libcall. */
3721 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
3725 gcc_assert (expr
->rank
> 0);
3727 newss
= gfc_get_ss ();
3728 newss
->type
= GFC_SS_FUNCTION
;
3731 newss
->data
.info
.dimen
= expr
->rank
;
3737 /* Returns nonzero if the specified intrinsic function call maps directly to a
3738 an external library call. Should only be used for functions that return
3742 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
3744 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
3745 gcc_assert (expr
->rank
> 0);
3747 switch (expr
->value
.function
.isym
->generic_id
)
3751 case GFC_ISYM_COUNT
:
3752 case GFC_ISYM_MATMUL
:
3753 case GFC_ISYM_MAXLOC
:
3754 case GFC_ISYM_MAXVAL
:
3755 case GFC_ISYM_MINLOC
:
3756 case GFC_ISYM_MINVAL
:
3757 case GFC_ISYM_PRODUCT
:
3759 case GFC_ISYM_SHAPE
:
3760 case GFC_ISYM_SPREAD
:
3761 case GFC_ISYM_TRANSPOSE
:
3762 /* Ignore absent optional parameters. */
3765 case GFC_ISYM_RESHAPE
:
3766 case GFC_ISYM_CSHIFT
:
3767 case GFC_ISYM_EOSHIFT
:
3769 case GFC_ISYM_UNPACK
:
3770 /* Pass absent optional parameters. */
3778 /* Walk an intrinsic function. */
3780 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
3781 gfc_intrinsic_sym
* isym
)
3785 if (isym
->elemental
)
3786 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
3788 if (expr
->rank
== 0)
3791 if (gfc_is_intrinsic_libcall (expr
))
3792 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3794 /* Special cases. */
3795 switch (isym
->generic_id
)
3797 case GFC_ISYM_LBOUND
:
3798 case GFC_ISYM_UBOUND
:
3799 return gfc_walk_intrinsic_bound (ss
, expr
);
3801 case GFC_ISYM_TRANSFER
:
3802 return gfc_walk_intrinsic_libfunc (ss
, expr
);
3805 /* This probably meant someone forgot to add an intrinsic to the above
3806 list(s) when they implemented it, or something's gone horribly wrong.
3808 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3809 expr
->value
.function
.name
);
3813 #include "gt-fortran-trans-intrinsic.h"