1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 /* This maps fortran intrinsic math functions to external library or GCC
48 typedef struct gfc_intrinsic_map_t
GTY(())
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function code_r4
;
57 enum built_in_function code_r8
;
58 enum built_in_function code_r10
;
59 enum built_in_function code_r16
;
60 enum built_in_function code_c4
;
61 enum built_in_function code_c8
;
62 enum built_in_function code_c10
;
63 enum built_in_function code_c16
;
65 /* True if the naming pattern is to prepend "c" for complex and
66 append "f" for kind=4. False if the naming pattern is to
67 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
70 /* True if a complex version of the function exists. */
71 bool complex_available
;
73 /* True if the function should be marked const. */
76 /* The base library name of this function. */
79 /* Cache decls created for the various operand types. */
91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 defines complex variants of all of the entries in mathbuiltins.def
94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
97 false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
103 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
104 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
107 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
108 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
115 /* Functions built into gcc itself. */
116 #include "mathbuiltins.def"
118 /* Functions in libgfortran. */
119 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
122 LIB_FUNCTION (NONE
, NULL
, false)
126 #undef DEFINE_MATH_BUILTIN
127 #undef DEFINE_MATH_BUILTIN_C
129 /* Structure for storing components of a floating number to be used by
130 elemental functions to manipulate reals. */
133 tree arg
; /* Variable tree to view convert to integer. */
134 tree expn
; /* Variable tree to save exponent. */
135 tree frac
; /* Variable tree to save fraction. */
136 tree smask
; /* Constant tree of sign's mask. */
137 tree emask
; /* Constant tree of exponent's mask. */
138 tree fmask
; /* Constant tree of fraction's mask. */
139 tree edigits
; /* Constant tree of the number of exponent bits. */
140 tree fdigits
; /* Constant tree of the number of fraction bits. */
141 tree f1
; /* Constant tree of the f1 defined in the real model. */
142 tree bias
; /* Constant tree of the bias of exponent in the memory. */
143 tree type
; /* Type tree of arg1. */
144 tree mtype
; /* Type tree of integer type. Kind is that of arg1. */
148 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
150 /* Evaluate the arguments to an intrinsic function. The value
151 of NARGS may be less than the actual number of arguments in EXPR
152 to allow optional "KIND" arguments that are not included in the
153 generated code to be ignored. */
156 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
157 tree
*argarray
, int nargs
)
159 gfc_actual_arglist
*actual
;
161 gfc_intrinsic_arg
*formal
;
165 formal
= expr
->value
.function
.isym
->formal
;
166 actual
= expr
->value
.function
.actual
;
168 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
169 actual
= actual
->next
,
170 formal
= formal
? formal
->next
: NULL
)
174 /* Skip omitted optional arguments. */
181 /* Evaluate the parameter. This will substitute scalarized
182 references automatically. */
183 gfc_init_se (&argse
, se
);
185 if (e
->ts
.type
== BT_CHARACTER
)
187 gfc_conv_expr (&argse
, e
);
188 gfc_conv_string_parameter (&argse
);
189 argarray
[curr_arg
++] = argse
.string_length
;
190 gcc_assert (curr_arg
< nargs
);
193 gfc_conv_expr_val (&argse
, e
);
195 /* If an optional argument is itself an optional dummy argument,
196 check its presence and substitute a null if absent. */
197 if (e
->expr_type
== EXPR_VARIABLE
198 && e
->symtree
->n
.sym
->attr
.optional
201 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
203 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
204 gfc_add_block_to_block (&se
->post
, &argse
.post
);
205 argarray
[curr_arg
] = argse
.expr
;
209 /* Count the number of actual arguments to the intrinsic function EXPR
210 including any "hidden" string length arguments. */
213 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
216 gfc_actual_arglist
*actual
;
218 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
223 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
233 /* Conversions between different types are output by the frontend as
234 intrinsic functions. We implement these directly with inline code. */
237 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
243 nargs
= gfc_intrinsic_argument_list_length (expr
);
244 args
= alloca (sizeof (tree
) * nargs
);
246 /* Evaluate all the arguments passed. Whilst we're only interested in the
247 first one here, there are other parts of the front-end that assume this
248 and will trigger an ICE if it's not the case. */
249 type
= gfc_typenode_for_spec (&expr
->ts
);
250 gcc_assert (expr
->value
.function
.actual
->expr
);
251 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
253 /* Conversion from complex to non-complex involves taking the real
254 component of the value. */
255 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
256 && expr
->ts
.type
!= BT_COMPLEX
)
260 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
261 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
264 se
->expr
= convert (type
, args
[0]);
267 /* This is needed because the gcc backend only implements
268 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
269 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
270 Similarly for CEILING. */
273 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
280 argtype
= TREE_TYPE (arg
);
281 arg
= gfc_evaluate_now (arg
, pblock
);
283 intval
= convert (type
, arg
);
284 intval
= gfc_evaluate_now (intval
, pblock
);
286 tmp
= convert (argtype
, intval
);
287 cond
= fold_build2 (up
? GE_EXPR
: LE_EXPR
, boolean_type_node
, tmp
, arg
);
289 tmp
= fold_build2 (up
? PLUS_EXPR
: MINUS_EXPR
, type
, intval
,
290 build_int_cst (type
, 1));
291 tmp
= fold_build3 (COND_EXPR
, type
, cond
, intval
, tmp
);
296 /* Round to nearest integer, away from zero. */
299 build_round_expr (tree arg
, tree restype
)
304 int argprec
, resprec
;
306 argtype
= TREE_TYPE (arg
);
307 argprec
= TYPE_PRECISION (argtype
);
308 resprec
= TYPE_PRECISION (restype
);
310 /* Depending on the type of the result, choose the long int intrinsic
311 (lround family) or long long intrinsic (llround). We might also
312 need to convert the result afterwards. */
313 if (resprec
<= LONG_TYPE_SIZE
)
315 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
320 /* Now, depending on the argument type, we choose between intrinsics. */
321 if (argprec
== TYPE_PRECISION (float_type_node
))
322 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDF
: BUILT_IN_LROUNDF
];
323 else if (argprec
== TYPE_PRECISION (double_type_node
))
324 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUND
: BUILT_IN_LROUND
];
325 else if (argprec
== TYPE_PRECISION (long_double_type_node
))
326 fn
= built_in_decls
[longlong
? BUILT_IN_LLROUNDL
: BUILT_IN_LROUNDL
];
330 return fold_convert (restype
, build_call_expr (fn
, 1, arg
));
334 /* Convert a real to an integer using a specific rounding mode.
335 Ideally we would just build the corresponding GENERIC node,
336 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
339 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
340 enum rounding_mode op
)
345 return build_fixbound_expr (pblock
, arg
, type
, 0);
349 return build_fixbound_expr (pblock
, arg
, type
, 1);
353 return build_round_expr (arg
, type
);
357 return fold_build1 (FIX_TRUNC_EXPR
, type
, arg
);
366 /* Round a real value using the specified rounding mode.
367 We use a temporary integer of that same kind size as the result.
368 Values larger than those that can be represented by this kind are
369 unchanged, as they will not be accurate enough to represent the
371 huge = HUGE (KIND (a))
372 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
376 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
387 kind
= expr
->ts
.kind
;
388 nargs
= gfc_intrinsic_argument_list_length (expr
);
391 /* We have builtin functions for some cases. */
434 /* Evaluate the argument. */
435 gcc_assert (expr
->value
.function
.actual
->expr
);
436 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
438 /* Use a builtin function if one exists. */
439 if (n
!= END_BUILTINS
)
441 tmp
= built_in_decls
[n
];
442 se
->expr
= build_call_expr (tmp
, 1, arg
[0]);
446 /* This code is probably redundant, but we'll keep it lying around just
448 type
= gfc_typenode_for_spec (&expr
->ts
);
449 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
451 /* Test if the value is too large to handle sensibly. */
452 gfc_set_model_kind (kind
);
454 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
455 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
456 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
457 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, arg
[0], tmp
);
459 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
460 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
);
461 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, arg
[0], tmp
);
462 cond
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond
, tmp
);
463 itype
= gfc_get_int_type (kind
);
465 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
466 tmp
= convert (type
, tmp
);
467 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
, tmp
, arg
[0]);
472 /* Convert to an integer using the specified rounding mode. */
475 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
481 nargs
= gfc_intrinsic_argument_list_length (expr
);
482 args
= alloca (sizeof (tree
) * nargs
);
484 /* Evaluate the argument, we process all arguments even though we only
485 use the first one for code generation purposes. */
486 type
= gfc_typenode_for_spec (&expr
->ts
);
487 gcc_assert (expr
->value
.function
.actual
->expr
);
488 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
490 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
492 /* Conversion to a different integer kind. */
493 se
->expr
= convert (type
, args
[0]);
497 /* Conversion from complex to non-complex involves taking the real
498 component of the value. */
499 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
500 && expr
->ts
.type
!= BT_COMPLEX
)
504 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
505 args
[0] = fold_build1 (REALPART_EXPR
, artype
, args
[0]);
508 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
513 /* Get the imaginary component of a value. */
516 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
520 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
521 se
->expr
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (arg
)), arg
);
525 /* Get the complex conjugate of a value. */
528 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
532 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
533 se
->expr
= fold_build1 (CONJ_EXPR
, TREE_TYPE (arg
), arg
);
537 /* Initialize function decls for library functions. The external functions
538 are created as required. Builtin functions are added here. */
541 gfc_build_intrinsic_lib_fndecls (void)
543 gfc_intrinsic_map_t
*m
;
545 /* Add GCC builtin functions. */
546 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
548 if (m
->code_r4
!= END_BUILTINS
)
549 m
->real4_decl
= built_in_decls
[m
->code_r4
];
550 if (m
->code_r8
!= END_BUILTINS
)
551 m
->real8_decl
= built_in_decls
[m
->code_r8
];
552 if (m
->code_r10
!= END_BUILTINS
)
553 m
->real10_decl
= built_in_decls
[m
->code_r10
];
554 if (m
->code_r16
!= END_BUILTINS
)
555 m
->real16_decl
= built_in_decls
[m
->code_r16
];
556 if (m
->code_c4
!= END_BUILTINS
)
557 m
->complex4_decl
= built_in_decls
[m
->code_c4
];
558 if (m
->code_c8
!= END_BUILTINS
)
559 m
->complex8_decl
= built_in_decls
[m
->code_c8
];
560 if (m
->code_c10
!= END_BUILTINS
)
561 m
->complex10_decl
= built_in_decls
[m
->code_c10
];
562 if (m
->code_c16
!= END_BUILTINS
)
563 m
->complex16_decl
= built_in_decls
[m
->code_c16
];
568 /* Create a fndecl for a simple intrinsic library function. */
571 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
576 gfc_actual_arglist
*actual
;
579 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
582 if (ts
->type
== BT_REAL
)
587 pdecl
= &m
->real4_decl
;
590 pdecl
= &m
->real8_decl
;
593 pdecl
= &m
->real10_decl
;
596 pdecl
= &m
->real16_decl
;
602 else if (ts
->type
== BT_COMPLEX
)
604 gcc_assert (m
->complex_available
);
609 pdecl
= &m
->complex4_decl
;
612 pdecl
= &m
->complex8_decl
;
615 pdecl
= &m
->complex10_decl
;
618 pdecl
= &m
->complex16_decl
;
633 snprintf (name
, sizeof (name
), "%s%s%s",
634 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
635 else if (ts
->kind
== 8)
636 snprintf (name
, sizeof (name
), "%s%s",
637 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
640 gcc_assert (ts
->kind
== 10 || ts
->kind
== 16);
641 snprintf (name
, sizeof (name
), "%s%s%s",
642 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
647 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
648 ts
->type
== BT_COMPLEX
? 'c' : 'r',
652 argtypes
= NULL_TREE
;
653 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
655 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
656 argtypes
= gfc_chainon_list (argtypes
, type
);
658 argtypes
= gfc_chainon_list (argtypes
, void_type_node
);
659 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
660 fndecl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
662 /* Mark the decl as external. */
663 DECL_EXTERNAL (fndecl
) = 1;
664 TREE_PUBLIC (fndecl
) = 1;
666 /* Mark it __attribute__((const)), if possible. */
667 TREE_READONLY (fndecl
) = m
->is_constant
;
669 rest_of_decl_compilation (fndecl
, 1, 0);
676 /* Convert an intrinsic function into an external or builtin call. */
679 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
681 gfc_intrinsic_map_t
*m
;
685 unsigned int num_args
;
688 id
= expr
->value
.function
.isym
->id
;
689 /* Find the entry for this function. */
690 for (m
= gfc_intrinsic_map
; m
->id
!= GFC_ISYM_NONE
; m
++)
696 if (m
->id
== GFC_ISYM_NONE
)
698 internal_error ("Intrinsic function %s(%d) not recognized",
699 expr
->value
.function
.name
, id
);
702 /* Get the decl and generate the call. */
703 num_args
= gfc_intrinsic_argument_list_length (expr
);
704 args
= alloca (sizeof (tree
) * num_args
);
706 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
707 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
708 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
710 fndecl
= build_addr (fndecl
, current_function_decl
);
711 se
->expr
= build_call_array (rettype
, fndecl
, num_args
, args
);
714 /* The EXPONENT(s) intrinsic function is translated into
721 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
723 tree arg
, type
, res
, tmp
;
726 switch (expr
->value
.function
.actual
->expr
->ts
.kind
)
729 frexp
= BUILT_IN_FREXPF
;
732 frexp
= BUILT_IN_FREXP
;
736 frexp
= BUILT_IN_FREXPL
;
742 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
744 res
= gfc_create_var (integer_type_node
, NULL
);
745 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
746 build_fold_addr_expr (res
));
747 gfc_add_expr_to_block (&se
->pre
, tmp
);
749 type
= gfc_typenode_for_spec (&expr
->ts
);
750 se
->expr
= fold_convert (type
, res
);
753 /* Evaluate a single upper or lower bound. */
754 /* TODO: bound intrinsic generates way too much unnecessary code. */
757 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
759 gfc_actual_arglist
*arg
;
760 gfc_actual_arglist
*arg2
;
765 tree cond
, cond1
, cond2
, cond3
, cond4
, size
;
773 arg
= expr
->value
.function
.actual
;
778 /* Create an implicit second parameter from the loop variable. */
779 gcc_assert (!arg2
->expr
);
780 gcc_assert (se
->loop
->dimen
== 1);
781 gcc_assert (se
->ss
->expr
== expr
);
782 gfc_advance_se_ss_chain (se
);
783 bound
= se
->loop
->loopvar
[0];
784 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
789 /* use the passed argument. */
790 gcc_assert (arg
->next
->expr
);
791 gfc_init_se (&argse
, NULL
);
792 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
793 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
795 /* Convert from one based to zero based. */
796 bound
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, bound
,
800 /* TODO: don't re-evaluate the descriptor on each iteration. */
801 /* Get a descriptor for the first parameter. */
802 ss
= gfc_walk_expr (arg
->expr
);
803 gcc_assert (ss
!= gfc_ss_terminator
);
804 gfc_init_se (&argse
, NULL
);
805 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
806 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
807 gfc_add_block_to_block (&se
->post
, &argse
.post
);
811 if (INTEGER_CST_P (bound
))
815 hi
= TREE_INT_CST_HIGH (bound
);
816 low
= TREE_INT_CST_LOW (bound
);
817 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
818 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
819 "dimension index", upper
? "UBOUND" : "LBOUND",
824 if (flag_bounds_check
)
826 bound
= gfc_evaluate_now (bound
, &se
->pre
);
827 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
828 bound
, build_int_cst (TREE_TYPE (bound
), 0));
829 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
830 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, bound
, tmp
);
831 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
, cond
, tmp
);
832 gfc_trans_runtime_check (cond
, &se
->pre
, &expr
->where
, gfc_msg_fault
);
836 ubound
= gfc_conv_descriptor_ubound (desc
, bound
);
837 lbound
= gfc_conv_descriptor_lbound (desc
, bound
);
839 /* Follow any component references. */
840 if (arg
->expr
->expr_type
== EXPR_VARIABLE
841 || arg
->expr
->expr_type
== EXPR_CONSTANT
)
843 as
= arg
->expr
->symtree
->n
.sym
->as
;
844 for (ref
= arg
->expr
->ref
; ref
; ref
= ref
->next
)
849 as
= ref
->u
.c
.component
->as
;
857 switch (ref
->u
.ar
.type
)
875 /* 13.14.53: Result value for LBOUND
877 Case (i): For an array section or for an array expression other than a
878 whole array or array structure component, LBOUND(ARRAY, DIM)
879 has the value 1. For a whole array or array structure
880 component, LBOUND(ARRAY, DIM) has the value:
881 (a) equal to the lower bound for subscript DIM of ARRAY if
882 dimension DIM of ARRAY does not have extent zero
883 or if ARRAY is an assumed-size array of rank DIM,
886 13.14.113: Result value for UBOUND
888 Case (i): For an array section or for an array expression other than a
889 whole array or array structure component, UBOUND(ARRAY, DIM)
890 has the value equal to the number of elements in the given
891 dimension; otherwise, it has a value equal to the upper bound
892 for subscript DIM of ARRAY if dimension DIM of ARRAY does
893 not have size zero and has value zero if dimension DIM has
898 tree stride
= gfc_conv_descriptor_stride (desc
, bound
);
900 cond1
= fold_build2 (GE_EXPR
, boolean_type_node
, ubound
, lbound
);
901 cond2
= fold_build2 (LE_EXPR
, boolean_type_node
, ubound
, lbound
);
903 cond3
= fold_build2 (GE_EXPR
, boolean_type_node
, stride
,
904 gfc_index_zero_node
);
905 cond3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond3
, cond1
);
907 cond4
= fold_build2 (LT_EXPR
, boolean_type_node
, stride
,
908 gfc_index_zero_node
);
909 cond4
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, cond4
, cond2
);
913 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
915 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
916 ubound
, gfc_index_zero_node
);
920 if (as
->type
== AS_ASSUMED_SIZE
)
921 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, bound
,
922 build_int_cst (TREE_TYPE (bound
),
923 arg
->expr
->rank
- 1));
925 cond
= boolean_false_node
;
927 cond1
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond3
, cond4
);
928 cond
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, cond
, cond1
);
930 se
->expr
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
931 lbound
, gfc_index_one_node
);
938 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
939 se
->expr
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
941 se
->expr
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, se
->expr
,
942 gfc_index_zero_node
);
945 se
->expr
= gfc_index_one_node
;
948 type
= gfc_typenode_for_spec (&expr
->ts
);
949 se
->expr
= convert (type
, se
->expr
);
954 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
959 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
961 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
965 se
->expr
= fold_build1 (ABS_EXPR
, TREE_TYPE (arg
), arg
);
969 switch (expr
->ts
.kind
)
984 se
->expr
= build_call_expr (built_in_decls
[n
], 1, arg
);
993 /* Create a complex value from one or two real components. */
996 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1002 unsigned int num_args
;
1004 num_args
= gfc_intrinsic_argument_list_length (expr
);
1005 args
= alloca (sizeof (tree
) * num_args
);
1007 type
= gfc_typenode_for_spec (&expr
->ts
);
1008 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1009 real
= convert (TREE_TYPE (type
), args
[0]);
1011 imag
= convert (TREE_TYPE (type
), args
[1]);
1012 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1014 imag
= fold_build1 (IMAGPART_EXPR
, TREE_TYPE (TREE_TYPE (args
[0])),
1016 imag
= convert (TREE_TYPE (type
), imag
);
1019 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1021 se
->expr
= fold_build2 (COMPLEX_EXPR
, type
, real
, imag
);
1024 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1025 MODULO(A, P) = A - FLOOR (A / P) * P */
1026 /* TODO: MOD(x, 0) */
1029 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1040 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1042 switch (expr
->ts
.type
)
1045 /* Integer case is easy, we've got a builtin op. */
1046 type
= TREE_TYPE (args
[0]);
1049 se
->expr
= fold_build2 (FLOOR_MOD_EXPR
, type
, args
[0], args
[1]);
1051 se
->expr
= fold_build2 (TRUNC_MOD_EXPR
, type
, args
[0], args
[1]);
1056 /* Check if we have a builtin fmod. */
1057 switch (expr
->ts
.kind
)
1076 /* Use it if it exists. */
1077 if (n
!= END_BUILTINS
)
1079 tmp
= build_addr (built_in_decls
[n
], current_function_decl
);
1080 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls
[n
])),
1086 type
= TREE_TYPE (args
[0]);
1088 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1089 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1092 modulo = arg - floor (arg/arg2) * arg2, so
1093 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1095 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1096 thereby avoiding another division and retaining the accuracy
1097 of the builtin function. */
1098 if (n
!= END_BUILTINS
&& modulo
)
1100 tree zero
= gfc_build_const (type
, integer_zero_node
);
1101 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1102 test
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[0], zero
);
1103 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, args
[1], zero
);
1104 test2
= fold_build2 (TRUTH_XOR_EXPR
, boolean_type_node
, test
, test2
);
1105 test
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, zero
);
1106 test
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1107 test
= gfc_evaluate_now (test
, &se
->pre
);
1108 se
->expr
= fold_build3 (COND_EXPR
, type
, test
,
1109 fold_build2 (PLUS_EXPR
, type
, tmp
, args
[1]),
1114 /* If we do not have a built_in fmod, the calculation is going to
1115 have to be done longhand. */
1116 tmp
= fold_build2 (RDIV_EXPR
, type
, args
[0], args
[1]);
1118 /* Test if the value is too large to handle sensibly. */
1119 gfc_set_model_kind (expr
->ts
.kind
);
1121 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1122 ikind
= expr
->ts
.kind
;
1125 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1126 ikind
= gfc_max_integer_kind
;
1128 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1129 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1130 test2
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, test
);
1132 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1133 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
);
1134 test
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp
, test
);
1135 test2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, test
, test2
);
1137 itype
= gfc_get_int_type (ikind
);
1139 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1141 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1142 tmp
= convert (type
, tmp
);
1143 tmp
= fold_build3 (COND_EXPR
, type
, test2
, tmp
, args
[0]);
1144 tmp
= fold_build2 (MULT_EXPR
, type
, tmp
, args
[1]);
1145 se
->expr
= fold_build2 (MINUS_EXPR
, type
, args
[0], tmp
);
1154 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1157 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1165 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1166 type
= TREE_TYPE (args
[0]);
1168 val
= fold_build2 (MINUS_EXPR
, type
, args
[0], args
[1]);
1169 val
= gfc_evaluate_now (val
, &se
->pre
);
1171 zero
= gfc_build_const (type
, integer_zero_node
);
1172 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, val
, zero
);
1173 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, zero
, val
);
1177 /* SIGN(A, B) is absolute value of A times sign of B.
1178 The real value versions use library functions to ensure the correct
1179 handling of negative zero. Integer case implemented as:
1180 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1184 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1190 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1191 if (expr
->ts
.type
== BT_REAL
)
1193 switch (expr
->ts
.kind
)
1196 tmp
= built_in_decls
[BUILT_IN_COPYSIGNF
];
1199 tmp
= built_in_decls
[BUILT_IN_COPYSIGN
];
1203 tmp
= built_in_decls
[BUILT_IN_COPYSIGNL
];
1208 se
->expr
= build_call_expr (tmp
, 2, args
[0], args
[1]);
1212 /* Having excluded floating point types, we know we are now dealing
1213 with signed integer types. */
1214 type
= TREE_TYPE (args
[0]);
1216 /* Args[0] is used multiple times below. */
1217 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1219 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1220 the signs of A and B are the same, and of all ones if they differ. */
1221 tmp
= fold_build2 (BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1222 tmp
= fold_build2 (RSHIFT_EXPR
, type
, tmp
,
1223 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1224 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1226 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1227 is all ones (i.e. -1). */
1228 se
->expr
= fold_build2 (BIT_XOR_EXPR
, type
,
1229 fold_build2 (PLUS_EXPR
, type
, args
[0], tmp
),
1234 /* Test for the presence of an optional argument. */
1237 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1241 arg
= expr
->value
.function
.actual
->expr
;
1242 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1243 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1244 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1248 /* Calculate the double precision product of two single precision values. */
1251 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1256 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1258 /* Convert the args to double precision before multiplying. */
1259 type
= gfc_typenode_for_spec (&expr
->ts
);
1260 args
[0] = convert (type
, args
[0]);
1261 args
[1] = convert (type
, args
[1]);
1262 se
->expr
= fold_build2 (MULT_EXPR
, type
, args
[0], args
[1]);
1266 /* Return a length one character string containing an ascii character. */
1269 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1274 unsigned int num_args
;
1276 /* We must allow for the KIND argument, even though.... */
1277 num_args
= gfc_intrinsic_argument_list_length (expr
);
1278 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
1280 /* .... we currently don't support character types != 1. */
1281 gcc_assert (expr
->ts
.kind
== 1);
1282 type
= gfc_character1_type_node
;
1283 var
= gfc_create_var (type
, "char");
1285 arg
[0] = convert (type
, arg
[0]);
1286 gfc_add_modify_expr (&se
->pre
, var
, arg
[0]);
1287 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1288 se
->string_length
= integer_one_node
;
1293 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1300 tree gfc_int8_type_node
= gfc_get_int_type (8);
1303 unsigned int num_args
;
1305 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1306 args
= alloca (sizeof (tree
) * num_args
);
1308 type
= build_pointer_type (gfc_character1_type_node
);
1309 var
= gfc_create_var (type
, "pstr");
1310 len
= gfc_create_var (gfc_int8_type_node
, "len");
1312 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1313 args
[0] = build_fold_addr_expr (var
);
1314 args
[1] = build_fold_addr_expr (len
);
1316 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
1317 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1318 fndecl
, num_args
, args
);
1319 gfc_add_expr_to_block (&se
->pre
, tmp
);
1321 /* Free the temporary afterwards, if necessary. */
1322 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1323 len
, build_int_cst (TREE_TYPE (len
), 0));
1324 tmp
= gfc_call_free (var
);
1325 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1326 gfc_add_expr_to_block (&se
->post
, tmp
);
1329 se
->string_length
= len
;
1334 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1341 tree gfc_int4_type_node
= gfc_get_int_type (4);
1344 unsigned int num_args
;
1346 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1347 args
= alloca (sizeof (tree
) * num_args
);
1349 type
= build_pointer_type (gfc_character1_type_node
);
1350 var
= gfc_create_var (type
, "pstr");
1351 len
= gfc_create_var (gfc_int4_type_node
, "len");
1353 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1354 args
[0] = build_fold_addr_expr (var
);
1355 args
[1] = build_fold_addr_expr (len
);
1357 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1358 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1359 fndecl
, num_args
, args
);
1360 gfc_add_expr_to_block (&se
->pre
, tmp
);
1362 /* Free the temporary afterwards, if necessary. */
1363 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1364 len
, build_int_cst (TREE_TYPE (len
), 0));
1365 tmp
= gfc_call_free (var
);
1366 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1367 gfc_add_expr_to_block (&se
->post
, tmp
);
1370 se
->string_length
= len
;
1374 /* Return a character string containing the tty name. */
1377 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1385 tree gfc_int4_type_node
= gfc_get_int_type (4);
1387 unsigned int num_args
;
1389 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1390 args
= alloca (sizeof (tree
) * num_args
);
1392 type
= build_pointer_type (gfc_character1_type_node
);
1393 var
= gfc_create_var (type
, "pstr");
1394 len
= gfc_create_var (gfc_int4_type_node
, "len");
1396 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1397 args
[0] = build_fold_addr_expr (var
);
1398 args
[1] = build_fold_addr_expr (len
);
1400 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1401 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1402 fndecl
, num_args
, args
);
1403 gfc_add_expr_to_block (&se
->pre
, tmp
);
1405 /* Free the temporary afterwards, if necessary. */
1406 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1407 len
, build_int_cst (TREE_TYPE (len
), 0));
1408 tmp
= gfc_call_free (var
);
1409 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1410 gfc_add_expr_to_block (&se
->post
, tmp
);
1413 se
->string_length
= len
;
1417 /* Get the minimum/maximum value of all the parameters.
1418 minmax (a1, a2, a3, ...)
1421 if (a2 .op. mvar || isnan(mvar))
1423 if (a3 .op. mvar || isnan(mvar))
1430 /* TODO: Mismatching types can occur when specific names are used.
1431 These should be handled during resolution. */
1433 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, int op
)
1441 gfc_actual_arglist
*argexpr
;
1442 unsigned int i
, nargs
;
1444 nargs
= gfc_intrinsic_argument_list_length (expr
);
1445 args
= alloca (sizeof (tree
) * nargs
);
1447 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1448 type
= gfc_typenode_for_spec (&expr
->ts
);
1450 argexpr
= expr
->value
.function
.actual
;
1451 if (TREE_TYPE (args
[0]) != type
)
1452 args
[0] = convert (type
, args
[0]);
1453 /* Only evaluate the argument once. */
1454 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
1455 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1457 mvar
= gfc_create_var (type
, "M");
1458 gfc_add_modify_expr (&se
->pre
, mvar
, args
[0]);
1459 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1465 /* Handle absent optional arguments by ignoring the comparison. */
1466 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1467 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1468 && TREE_CODE (val
) == INDIRECT_REF
)
1470 (NE_EXPR
, boolean_type_node
, TREE_OPERAND (val
, 0),
1471 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1476 /* Only evaluate the argument once. */
1477 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1478 val
= gfc_evaluate_now (val
, &se
->pre
);
1481 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1483 tmp
= fold_build2 (op
, boolean_type_node
, convert (type
, val
), mvar
);
1485 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1486 __builtin_isnan might be made dependent on that module being loaded,
1487 to help performance of programs that don't rely on IEEE semantics. */
1488 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
1490 isnan
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, mvar
);
1491 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
,
1492 fold_convert (boolean_type_node
, isnan
));
1494 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, build_empty_stmt ());
1496 if (cond
!= NULL_TREE
)
1497 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1499 gfc_add_expr_to_block (&se
->pre
, tmp
);
1500 argexpr
= argexpr
->next
;
1506 /* Generate library calls for MIN and MAX intrinsics for character
1509 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
1512 tree var
, len
, fndecl
, tmp
, cond
, function
;
1515 nargs
= gfc_intrinsic_argument_list_length (expr
);
1516 args
= alloca (sizeof (tree
) * (nargs
+ 4));
1517 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
1519 /* Create the result variables. */
1520 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1521 args
[0] = build_fold_addr_expr (len
);
1522 var
= gfc_create_var (build_pointer_type (gfc_character1_type_node
), "pstr");
1523 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
1524 args
[2] = build_int_cst (NULL_TREE
, op
);
1525 args
[3] = build_int_cst (NULL_TREE
, nargs
/ 2);
1527 if (expr
->ts
.kind
== 1)
1528 function
= gfor_fndecl_string_minmax
;
1529 else if (expr
->ts
.kind
== 4)
1530 function
= gfor_fndecl_string_minmax_char4
;
1534 /* Make the function call. */
1535 fndecl
= build_addr (function
, current_function_decl
);
1536 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
1538 gfc_add_expr_to_block (&se
->pre
, tmp
);
1540 /* Free the temporary afterwards, if necessary. */
1541 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1542 len
, build_int_cst (TREE_TYPE (len
), 0));
1543 tmp
= gfc_call_free (var
);
1544 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1545 gfc_add_expr_to_block (&se
->post
, tmp
);
1548 se
->string_length
= len
;
1552 /* Create a symbol node for this intrinsic. The symbol from the frontend
1553 has the generic name. */
1556 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1560 /* TODO: Add symbols for intrinsic function to the global namespace. */
1561 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1562 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1565 sym
->attr
.external
= 1;
1566 sym
->attr
.function
= 1;
1567 sym
->attr
.always_explicit
= 1;
1568 sym
->attr
.proc
= PROC_INTRINSIC
;
1569 sym
->attr
.flavor
= FL_PROCEDURE
;
1573 sym
->attr
.dimension
= 1;
1574 sym
->as
= gfc_get_array_spec ();
1575 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1576 sym
->as
->rank
= expr
->rank
;
1579 /* TODO: proper argument lists for external intrinsics. */
1583 /* Generate a call to an external intrinsic function. */
1585 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1590 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1593 gcc_assert (expr
->rank
> 0);
1595 gcc_assert (expr
->rank
== 0);
1597 sym
= gfc_get_symbol_for_expr (expr
);
1599 /* Calls to libgfortran_matmul need to be appended special arguments,
1600 to be able to call the BLAS ?gemm functions if required and possible. */
1601 append_args
= NULL_TREE
;
1602 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1603 && sym
->ts
.type
!= BT_LOGICAL
)
1605 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1607 if (gfc_option
.flag_external_blas
1608 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1609 && (sym
->ts
.kind
== gfc_default_real_kind
1610 || sym
->ts
.kind
== gfc_default_double_kind
))
1614 if (sym
->ts
.type
== BT_REAL
)
1616 if (sym
->ts
.kind
== gfc_default_real_kind
)
1617 gemm_fndecl
= gfor_fndecl_sgemm
;
1619 gemm_fndecl
= gfor_fndecl_dgemm
;
1623 if (sym
->ts
.kind
== gfc_default_real_kind
)
1624 gemm_fndecl
= gfor_fndecl_cgemm
;
1626 gemm_fndecl
= gfor_fndecl_zgemm
;
1629 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 1));
1630 append_args
= gfc_chainon_list
1631 (append_args
, build_int_cst
1632 (cint
, gfc_option
.blas_matmul_limit
));
1633 append_args
= gfc_chainon_list (append_args
,
1634 gfc_build_addr_expr (NULL_TREE
,
1639 append_args
= gfc_chainon_list (NULL_TREE
, build_int_cst (cint
, 0));
1640 append_args
= gfc_chainon_list (append_args
, build_int_cst (cint
, 0));
1641 append_args
= gfc_chainon_list (append_args
, null_pointer_node
);
1645 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, append_args
);
1649 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1669 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, int op
)
1678 gfc_actual_arglist
*actual
;
1685 gfc_conv_intrinsic_funcall (se
, expr
);
1689 actual
= expr
->value
.function
.actual
;
1690 type
= gfc_typenode_for_spec (&expr
->ts
);
1691 /* Initialize the result. */
1692 resvar
= gfc_create_var (type
, "test");
1694 tmp
= convert (type
, boolean_true_node
);
1696 tmp
= convert (type
, boolean_false_node
);
1697 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1699 /* Walk the arguments. */
1700 arrayss
= gfc_walk_expr (actual
->expr
);
1701 gcc_assert (arrayss
!= gfc_ss_terminator
);
1703 /* Initialize the scalarizer. */
1704 gfc_init_loopinfo (&loop
);
1705 exit_label
= gfc_build_label_decl (NULL_TREE
);
1706 TREE_USED (exit_label
) = 1;
1707 gfc_add_ss_to_loop (&loop
, arrayss
);
1709 /* Initialize the loop. */
1710 gfc_conv_ss_startstride (&loop
);
1711 gfc_conv_loop_setup (&loop
);
1713 gfc_mark_ss_chain_used (arrayss
, 1);
1714 /* Generate the loop body. */
1715 gfc_start_scalarized_body (&loop
, &body
);
1717 /* If the condition matches then set the return value. */
1718 gfc_start_block (&block
);
1720 tmp
= convert (type
, boolean_false_node
);
1722 tmp
= convert (type
, boolean_true_node
);
1723 gfc_add_modify_expr (&block
, resvar
, tmp
);
1725 /* And break out of the loop. */
1726 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1727 gfc_add_expr_to_block (&block
, tmp
);
1729 found
= gfc_finish_block (&block
);
1731 /* Check this element. */
1732 gfc_init_se (&arrayse
, NULL
);
1733 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1734 arrayse
.ss
= arrayss
;
1735 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1737 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1738 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
,
1739 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1740 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt ());
1741 gfc_add_expr_to_block (&body
, tmp
);
1742 gfc_add_block_to_block (&body
, &arrayse
.post
);
1744 gfc_trans_scalarizing_loops (&loop
, &body
);
1746 /* Add the exit label. */
1747 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1748 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1750 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1751 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1752 gfc_cleanup_loop (&loop
);
1757 /* COUNT(A) = Number of true elements in A. */
1759 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1766 gfc_actual_arglist
*actual
;
1772 gfc_conv_intrinsic_funcall (se
, expr
);
1776 actual
= expr
->value
.function
.actual
;
1778 type
= gfc_typenode_for_spec (&expr
->ts
);
1779 /* Initialize the result. */
1780 resvar
= gfc_create_var (type
, "count");
1781 gfc_add_modify_expr (&se
->pre
, resvar
, build_int_cst (type
, 0));
1783 /* Walk the arguments. */
1784 arrayss
= gfc_walk_expr (actual
->expr
);
1785 gcc_assert (arrayss
!= gfc_ss_terminator
);
1787 /* Initialize the scalarizer. */
1788 gfc_init_loopinfo (&loop
);
1789 gfc_add_ss_to_loop (&loop
, arrayss
);
1791 /* Initialize the loop. */
1792 gfc_conv_ss_startstride (&loop
);
1793 gfc_conv_loop_setup (&loop
);
1795 gfc_mark_ss_chain_used (arrayss
, 1);
1796 /* Generate the loop body. */
1797 gfc_start_scalarized_body (&loop
, &body
);
1799 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (resvar
),
1800 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
1801 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
1803 gfc_init_se (&arrayse
, NULL
);
1804 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1805 arrayse
.ss
= arrayss
;
1806 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1807 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
, build_empty_stmt ());
1809 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1810 gfc_add_expr_to_block (&body
, tmp
);
1811 gfc_add_block_to_block (&body
, &arrayse
.post
);
1813 gfc_trans_scalarizing_loops (&loop
, &body
);
1815 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1816 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1817 gfc_cleanup_loop (&loop
);
1822 /* Inline implementation of the sum and product intrinsics. */
1824 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, int op
)
1832 gfc_actual_arglist
*actual
;
1837 gfc_expr
*arrayexpr
;
1842 gfc_conv_intrinsic_funcall (se
, expr
);
1846 type
= gfc_typenode_for_spec (&expr
->ts
);
1847 /* Initialize the result. */
1848 resvar
= gfc_create_var (type
, "val");
1849 if (op
== PLUS_EXPR
)
1850 tmp
= gfc_build_const (type
, integer_zero_node
);
1852 tmp
= gfc_build_const (type
, integer_one_node
);
1854 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1856 /* Walk the arguments. */
1857 actual
= expr
->value
.function
.actual
;
1858 arrayexpr
= actual
->expr
;
1859 arrayss
= gfc_walk_expr (arrayexpr
);
1860 gcc_assert (arrayss
!= gfc_ss_terminator
);
1862 actual
= actual
->next
->next
;
1863 gcc_assert (actual
);
1864 maskexpr
= actual
->expr
;
1865 if (maskexpr
&& maskexpr
->rank
!= 0)
1867 maskss
= gfc_walk_expr (maskexpr
);
1868 gcc_assert (maskss
!= gfc_ss_terminator
);
1873 /* Initialize the scalarizer. */
1874 gfc_init_loopinfo (&loop
);
1875 gfc_add_ss_to_loop (&loop
, arrayss
);
1877 gfc_add_ss_to_loop (&loop
, maskss
);
1879 /* Initialize the loop. */
1880 gfc_conv_ss_startstride (&loop
);
1881 gfc_conv_loop_setup (&loop
);
1883 gfc_mark_ss_chain_used (arrayss
, 1);
1885 gfc_mark_ss_chain_used (maskss
, 1);
1886 /* Generate the loop body. */
1887 gfc_start_scalarized_body (&loop
, &body
);
1889 /* If we have a mask, only add this element if the mask is set. */
1892 gfc_init_se (&maskse
, NULL
);
1893 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
1895 gfc_conv_expr_val (&maskse
, maskexpr
);
1896 gfc_add_block_to_block (&body
, &maskse
.pre
);
1898 gfc_start_block (&block
);
1901 gfc_init_block (&block
);
1903 /* Do the actual summation/product. */
1904 gfc_init_se (&arrayse
, NULL
);
1905 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1906 arrayse
.ss
= arrayss
;
1907 gfc_conv_expr_val (&arrayse
, arrayexpr
);
1908 gfc_add_block_to_block (&block
, &arrayse
.pre
);
1910 tmp
= fold_build2 (op
, type
, resvar
, arrayse
.expr
);
1911 gfc_add_modify_expr (&block
, resvar
, tmp
);
1912 gfc_add_block_to_block (&block
, &arrayse
.post
);
1916 /* We enclose the above in if (mask) {...} . */
1917 tmp
= gfc_finish_block (&block
);
1919 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1922 tmp
= gfc_finish_block (&block
);
1923 gfc_add_expr_to_block (&body
, tmp
);
1925 gfc_trans_scalarizing_loops (&loop
, &body
);
1927 /* For a scalar mask, enclose the loop in an if statement. */
1928 if (maskexpr
&& maskss
== NULL
)
1930 gfc_init_se (&maskse
, NULL
);
1931 gfc_conv_expr_val (&maskse
, maskexpr
);
1932 gfc_init_block (&block
);
1933 gfc_add_block_to_block (&block
, &loop
.pre
);
1934 gfc_add_block_to_block (&block
, &loop
.post
);
1935 tmp
= gfc_finish_block (&block
);
1937 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
1938 gfc_add_expr_to_block (&block
, tmp
);
1939 gfc_add_block_to_block (&se
->pre
, &block
);
1943 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1944 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1947 gfc_cleanup_loop (&loop
);
1953 /* Inline implementation of the dot_product intrinsic. This function
1954 is based on gfc_conv_intrinsic_arith (the previous function). */
1956 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
1964 gfc_actual_arglist
*actual
;
1965 gfc_ss
*arrayss1
, *arrayss2
;
1966 gfc_se arrayse1
, arrayse2
;
1967 gfc_expr
*arrayexpr1
, *arrayexpr2
;
1969 type
= gfc_typenode_for_spec (&expr
->ts
);
1971 /* Initialize the result. */
1972 resvar
= gfc_create_var (type
, "val");
1973 if (expr
->ts
.type
== BT_LOGICAL
)
1974 tmp
= build_int_cst (type
, 0);
1976 tmp
= gfc_build_const (type
, integer_zero_node
);
1978 gfc_add_modify_expr (&se
->pre
, resvar
, tmp
);
1980 /* Walk argument #1. */
1981 actual
= expr
->value
.function
.actual
;
1982 arrayexpr1
= actual
->expr
;
1983 arrayss1
= gfc_walk_expr (arrayexpr1
);
1984 gcc_assert (arrayss1
!= gfc_ss_terminator
);
1986 /* Walk argument #2. */
1987 actual
= actual
->next
;
1988 arrayexpr2
= actual
->expr
;
1989 arrayss2
= gfc_walk_expr (arrayexpr2
);
1990 gcc_assert (arrayss2
!= gfc_ss_terminator
);
1992 /* Initialize the scalarizer. */
1993 gfc_init_loopinfo (&loop
);
1994 gfc_add_ss_to_loop (&loop
, arrayss1
);
1995 gfc_add_ss_to_loop (&loop
, arrayss2
);
1997 /* Initialize the loop. */
1998 gfc_conv_ss_startstride (&loop
);
1999 gfc_conv_loop_setup (&loop
);
2001 gfc_mark_ss_chain_used (arrayss1
, 1);
2002 gfc_mark_ss_chain_used (arrayss2
, 1);
2004 /* Generate the loop body. */
2005 gfc_start_scalarized_body (&loop
, &body
);
2006 gfc_init_block (&block
);
2008 /* Make the tree expression for [conjg(]array1[)]. */
2009 gfc_init_se (&arrayse1
, NULL
);
2010 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2011 arrayse1
.ss
= arrayss1
;
2012 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2013 if (expr
->ts
.type
== BT_COMPLEX
)
2014 arrayse1
.expr
= fold_build1 (CONJ_EXPR
, type
, arrayse1
.expr
);
2015 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2017 /* Make the tree expression for array2. */
2018 gfc_init_se (&arrayse2
, NULL
);
2019 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2020 arrayse2
.ss
= arrayss2
;
2021 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2022 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2024 /* Do the actual product and sum. */
2025 if (expr
->ts
.type
== BT_LOGICAL
)
2027 tmp
= fold_build2 (TRUTH_AND_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2028 tmp
= fold_build2 (TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2032 tmp
= fold_build2 (MULT_EXPR
, type
, arrayse1
.expr
, arrayse2
.expr
);
2033 tmp
= fold_build2 (PLUS_EXPR
, type
, resvar
, tmp
);
2035 gfc_add_modify_expr (&block
, resvar
, tmp
);
2037 /* Finish up the loop block and the loop. */
2038 tmp
= gfc_finish_block (&block
);
2039 gfc_add_expr_to_block (&body
, tmp
);
2041 gfc_trans_scalarizing_loops (&loop
, &body
);
2042 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2043 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2044 gfc_cleanup_loop (&loop
);
2051 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, int op
)
2055 stmtblock_t ifblock
;
2056 stmtblock_t elseblock
;
2064 gfc_actual_arglist
*actual
;
2069 gfc_expr
*arrayexpr
;
2076 gfc_conv_intrinsic_funcall (se
, expr
);
2080 /* Initialize the result. */
2081 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2082 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2083 type
= gfc_typenode_for_spec (&expr
->ts
);
2085 /* Walk the arguments. */
2086 actual
= expr
->value
.function
.actual
;
2087 arrayexpr
= actual
->expr
;
2088 arrayss
= gfc_walk_expr (arrayexpr
);
2089 gcc_assert (arrayss
!= gfc_ss_terminator
);
2091 actual
= actual
->next
->next
;
2092 gcc_assert (actual
);
2093 maskexpr
= actual
->expr
;
2094 if (maskexpr
&& maskexpr
->rank
!= 0)
2096 maskss
= gfc_walk_expr (maskexpr
);
2097 gcc_assert (maskss
!= gfc_ss_terminator
);
2102 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2103 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2104 switch (arrayexpr
->ts
.type
)
2107 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, arrayexpr
->ts
.kind
);
2111 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2112 arrayexpr
->ts
.kind
);
2119 /* We start with the most negative possible value for MAXLOC, and the most
2120 positive possible value for MINLOC. The most negative possible value is
2121 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2122 possible value is HUGE in both cases. */
2124 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2125 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
2127 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2128 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2129 build_int_cst (type
, 1));
2131 /* Initialize the scalarizer. */
2132 gfc_init_loopinfo (&loop
);
2133 gfc_add_ss_to_loop (&loop
, arrayss
);
2135 gfc_add_ss_to_loop (&loop
, maskss
);
2137 /* Initialize the loop. */
2138 gfc_conv_ss_startstride (&loop
);
2139 gfc_conv_loop_setup (&loop
);
2141 gcc_assert (loop
.dimen
== 1);
2143 /* Initialize the position to zero, following Fortran 2003. We are free
2144 to do this because Fortran 95 allows the result of an entirely false
2145 mask to be processor dependent. */
2146 gfc_add_modify_expr (&loop
.pre
, pos
, gfc_index_zero_node
);
2148 gfc_mark_ss_chain_used (arrayss
, 1);
2150 gfc_mark_ss_chain_used (maskss
, 1);
2151 /* Generate the loop body. */
2152 gfc_start_scalarized_body (&loop
, &body
);
2154 /* If we have a mask, only check this element if the mask is set. */
2157 gfc_init_se (&maskse
, NULL
);
2158 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2160 gfc_conv_expr_val (&maskse
, maskexpr
);
2161 gfc_add_block_to_block (&body
, &maskse
.pre
);
2163 gfc_start_block (&block
);
2166 gfc_init_block (&block
);
2168 /* Compare with the current limit. */
2169 gfc_init_se (&arrayse
, NULL
);
2170 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2171 arrayse
.ss
= arrayss
;
2172 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2173 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2175 /* We do the following if this is a more extreme value. */
2176 gfc_start_block (&ifblock
);
2178 /* Assign the value to the limit... */
2179 gfc_add_modify_expr (&ifblock
, limit
, arrayse
.expr
);
2181 /* Remember where we are. An offset must be added to the loop
2182 counter to obtain the required position. */
2184 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2185 gfc_index_one_node
, loop
.from
[0]);
2187 tmp
= build_int_cst (gfc_array_index_type
, 1);
2189 gfc_add_modify_expr (&block
, offset
, tmp
);
2191 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (pos
),
2192 loop
.loopvar
[0], offset
);
2193 gfc_add_modify_expr (&ifblock
, pos
, tmp
);
2195 ifbody
= gfc_finish_block (&ifblock
);
2197 /* If it is a more extreme value or pos is still zero and the value
2198 equal to the limit. */
2199 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2200 fold_build2 (EQ_EXPR
, boolean_type_node
,
2201 pos
, gfc_index_zero_node
),
2202 fold_build2 (EQ_EXPR
, boolean_type_node
,
2203 arrayse
.expr
, limit
));
2204 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2205 fold_build2 (op
, boolean_type_node
,
2206 arrayse
.expr
, limit
), tmp
);
2207 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2208 gfc_add_expr_to_block (&block
, tmp
);
2212 /* We enclose the above in if (mask) {...}. */
2213 tmp
= gfc_finish_block (&block
);
2215 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2218 tmp
= gfc_finish_block (&block
);
2219 gfc_add_expr_to_block (&body
, tmp
);
2221 gfc_trans_scalarizing_loops (&loop
, &body
);
2223 /* For a scalar mask, enclose the loop in an if statement. */
2224 if (maskexpr
&& maskss
== NULL
)
2226 gfc_init_se (&maskse
, NULL
);
2227 gfc_conv_expr_val (&maskse
, maskexpr
);
2228 gfc_init_block (&block
);
2229 gfc_add_block_to_block (&block
, &loop
.pre
);
2230 gfc_add_block_to_block (&block
, &loop
.post
);
2231 tmp
= gfc_finish_block (&block
);
2233 /* For the else part of the scalar mask, just initialize
2234 the pos variable the same way as above. */
2236 gfc_init_block (&elseblock
);
2237 gfc_add_modify_expr (&elseblock
, pos
, gfc_index_zero_node
);
2238 elsetmp
= gfc_finish_block (&elseblock
);
2240 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2241 gfc_add_expr_to_block (&block
, tmp
);
2242 gfc_add_block_to_block (&se
->pre
, &block
);
2246 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2247 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2249 gfc_cleanup_loop (&loop
);
2251 se
->expr
= convert (type
, pos
);
2255 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, int op
)
2264 gfc_actual_arglist
*actual
;
2269 gfc_expr
*arrayexpr
;
2275 gfc_conv_intrinsic_funcall (se
, expr
);
2279 type
= gfc_typenode_for_spec (&expr
->ts
);
2280 /* Initialize the result. */
2281 limit
= gfc_create_var (type
, "limit");
2282 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2283 switch (expr
->ts
.type
)
2286 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
, expr
->ts
.kind
);
2290 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2297 /* We start with the most negative possible value for MAXVAL, and the most
2298 positive possible value for MINVAL. The most negative possible value is
2299 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2300 possible value is HUGE in both cases. */
2302 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2304 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2305 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
),
2306 tmp
, build_int_cst (type
, 1));
2308 gfc_add_modify_expr (&se
->pre
, limit
, tmp
);
2310 /* Walk the arguments. */
2311 actual
= expr
->value
.function
.actual
;
2312 arrayexpr
= actual
->expr
;
2313 arrayss
= gfc_walk_expr (arrayexpr
);
2314 gcc_assert (arrayss
!= gfc_ss_terminator
);
2316 actual
= actual
->next
->next
;
2317 gcc_assert (actual
);
2318 maskexpr
= actual
->expr
;
2319 if (maskexpr
&& maskexpr
->rank
!= 0)
2321 maskss
= gfc_walk_expr (maskexpr
);
2322 gcc_assert (maskss
!= gfc_ss_terminator
);
2327 /* Initialize the scalarizer. */
2328 gfc_init_loopinfo (&loop
);
2329 gfc_add_ss_to_loop (&loop
, arrayss
);
2331 gfc_add_ss_to_loop (&loop
, maskss
);
2333 /* Initialize the loop. */
2334 gfc_conv_ss_startstride (&loop
);
2335 gfc_conv_loop_setup (&loop
);
2337 gfc_mark_ss_chain_used (arrayss
, 1);
2339 gfc_mark_ss_chain_used (maskss
, 1);
2340 /* Generate the loop body. */
2341 gfc_start_scalarized_body (&loop
, &body
);
2343 /* If we have a mask, only add this element if the mask is set. */
2346 gfc_init_se (&maskse
, NULL
);
2347 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2349 gfc_conv_expr_val (&maskse
, maskexpr
);
2350 gfc_add_block_to_block (&body
, &maskse
.pre
);
2352 gfc_start_block (&block
);
2355 gfc_init_block (&block
);
2357 /* Compare with the current limit. */
2358 gfc_init_se (&arrayse
, NULL
);
2359 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2360 arrayse
.ss
= arrayss
;
2361 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2362 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2364 /* Assign the value to the limit... */
2365 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
2367 /* If it is a more extreme value. */
2368 tmp
= fold_build2 (op
, boolean_type_node
, arrayse
.expr
, limit
);
2369 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
, build_empty_stmt ());
2370 gfc_add_expr_to_block (&block
, tmp
);
2371 gfc_add_block_to_block (&block
, &arrayse
.post
);
2373 tmp
= gfc_finish_block (&block
);
2375 /* We enclose the above in if (mask) {...}. */
2376 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2377 gfc_add_expr_to_block (&body
, tmp
);
2379 gfc_trans_scalarizing_loops (&loop
, &body
);
2381 /* For a scalar mask, enclose the loop in an if statement. */
2382 if (maskexpr
&& maskss
== NULL
)
2384 gfc_init_se (&maskse
, NULL
);
2385 gfc_conv_expr_val (&maskse
, maskexpr
);
2386 gfc_init_block (&block
);
2387 gfc_add_block_to_block (&block
, &loop
.pre
);
2388 gfc_add_block_to_block (&block
, &loop
.post
);
2389 tmp
= gfc_finish_block (&block
);
2391 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, build_empty_stmt ());
2392 gfc_add_expr_to_block (&block
, tmp
);
2393 gfc_add_block_to_block (&se
->pre
, &block
);
2397 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2398 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2401 gfc_cleanup_loop (&loop
);
2406 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2408 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
2414 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2415 type
= TREE_TYPE (args
[0]);
2417 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2418 tmp
= fold_build2 (BIT_AND_EXPR
, type
, args
[0], tmp
);
2419 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
2420 build_int_cst (type
, 0));
2421 type
= gfc_typenode_for_spec (&expr
->ts
);
2422 se
->expr
= convert (type
, tmp
);
2425 /* Generate code to perform the specified operation. */
2427 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, int op
)
2431 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2432 se
->expr
= fold_build2 (op
, TREE_TYPE (args
[0]), args
[0], args
[1]);
2437 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
2441 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2442 se
->expr
= fold_build1 (BIT_NOT_EXPR
, TREE_TYPE (arg
), arg
);
2445 /* Set or clear a single bit. */
2447 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
2454 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2455 type
= TREE_TYPE (args
[0]);
2457 tmp
= fold_build2 (LSHIFT_EXPR
, type
, build_int_cst (type
, 1), args
[1]);
2463 tmp
= fold_build1 (BIT_NOT_EXPR
, type
, tmp
);
2465 se
->expr
= fold_build2 (op
, type
, args
[0], tmp
);
2468 /* Extract a sequence of bits.
2469 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2471 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
2478 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2479 type
= TREE_TYPE (args
[0]);
2481 mask
= build_int_cst (type
, -1);
2482 mask
= fold_build2 (LSHIFT_EXPR
, type
, mask
, args
[2]);
2483 mask
= fold_build1 (BIT_NOT_EXPR
, type
, mask
);
2485 tmp
= fold_build2 (RSHIFT_EXPR
, type
, args
[0], args
[1]);
2487 se
->expr
= fold_build2 (BIT_AND_EXPR
, type
, tmp
, mask
);
2490 /* RSHIFT (I, SHIFT) = I >> SHIFT
2491 LSHIFT (I, SHIFT) = I << SHIFT */
2493 gfc_conv_intrinsic_rlshift (gfc_se
* se
, gfc_expr
* expr
, int right_shift
)
2497 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2499 se
->expr
= fold_build2 (right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
2500 TREE_TYPE (args
[0]), args
[0], args
[1]);
2503 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2505 : ((shift >= 0) ? i << shift : i >> -shift)
2506 where all shifts are logical shifts. */
2508 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
2520 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2521 type
= TREE_TYPE (args
[0]);
2522 utype
= unsigned_type_for (type
);
2524 width
= fold_build1 (ABS_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2526 /* Left shift if positive. */
2527 lshift
= fold_build2 (LSHIFT_EXPR
, type
, args
[0], width
);
2529 /* Right shift if negative.
2530 We convert to an unsigned type because we want a logical shift.
2531 The standard doesn't define the case of shifting negative
2532 numbers, and we try to be compatible with other compilers, most
2533 notably g77, here. */
2534 rshift
= fold_convert (type
, fold_build2 (RSHIFT_EXPR
, utype
,
2535 convert (utype
, args
[0]), width
));
2537 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, args
[1],
2538 build_int_cst (TREE_TYPE (args
[1]), 0));
2539 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, lshift
, rshift
);
2541 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2542 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2544 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
2545 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, width
, num_bits
);
2547 se
->expr
= fold_build3 (COND_EXPR
, type
, cond
,
2548 build_int_cst (type
, 0), tmp
);
2552 /* Circular shift. AKA rotate or barrel shift. */
2555 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
2563 unsigned int num_args
;
2565 num_args
= gfc_intrinsic_argument_list_length (expr
);
2566 args
= alloca (sizeof (tree
) * num_args
);
2568 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2572 /* Use a library function for the 3 parameter version. */
2573 tree int4type
= gfc_get_int_type (4);
2575 type
= TREE_TYPE (args
[0]);
2576 /* We convert the first argument to at least 4 bytes, and
2577 convert back afterwards. This removes the need for library
2578 functions for all argument sizes, and function will be
2579 aligned to at least 32 bits, so there's no loss. */
2580 if (expr
->ts
.kind
< 4)
2581 args
[0] = convert (int4type
, args
[0]);
2583 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2584 need loads of library functions. They cannot have values >
2585 BIT_SIZE (I) so the conversion is safe. */
2586 args
[1] = convert (int4type
, args
[1]);
2587 args
[2] = convert (int4type
, args
[2]);
2589 switch (expr
->ts
.kind
)
2594 tmp
= gfor_fndecl_math_ishftc4
;
2597 tmp
= gfor_fndecl_math_ishftc8
;
2600 tmp
= gfor_fndecl_math_ishftc16
;
2605 se
->expr
= build_call_expr (tmp
, 3, args
[0], args
[1], args
[2]);
2606 /* Convert the result back to the original type, if we extended
2607 the first argument's width above. */
2608 if (expr
->ts
.kind
< 4)
2609 se
->expr
= convert (type
, se
->expr
);
2613 type
= TREE_TYPE (args
[0]);
2615 /* Rotate left if positive. */
2616 lrot
= fold_build2 (LROTATE_EXPR
, type
, args
[0], args
[1]);
2618 /* Rotate right if negative. */
2619 tmp
= fold_build1 (NEGATE_EXPR
, TREE_TYPE (args
[1]), args
[1]);
2620 rrot
= fold_build2 (RROTATE_EXPR
, type
, args
[0], tmp
);
2622 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
2623 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, args
[1], zero
);
2624 rrot
= fold_build3 (COND_EXPR
, type
, tmp
, lrot
, rrot
);
2626 /* Do nothing if shift == 0. */
2627 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, args
[1], zero
);
2628 se
->expr
= fold_build3 (COND_EXPR
, type
, tmp
, args
[0], rrot
);
2631 /* The length of a character string. */
2633 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
2643 gcc_assert (!se
->ss
);
2645 arg
= expr
->value
.function
.actual
->expr
;
2647 type
= gfc_typenode_for_spec (&expr
->ts
);
2648 switch (arg
->expr_type
)
2651 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
2655 /* Obtain the string length from the function used by
2656 trans-array.c(gfc_trans_array_constructor). */
2658 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
2662 if (arg
->ref
== NULL
2663 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
2665 /* This doesn't catch all cases.
2666 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2667 and the surrounding thread. */
2668 sym
= arg
->symtree
->n
.sym
;
2669 decl
= gfc_get_symbol_decl (sym
);
2670 if (decl
== current_function_decl
&& sym
->attr
.function
2671 && (sym
->result
== sym
))
2672 decl
= gfc_get_fake_result_decl (sym
, 0);
2674 len
= sym
->ts
.cl
->backend_decl
;
2679 /* Otherwise fall through. */
2682 /* Anybody stupid enough to do this deserves inefficient code. */
2683 ss
= gfc_walk_expr (arg
);
2684 gfc_init_se (&argse
, se
);
2685 if (ss
== gfc_ss_terminator
)
2686 gfc_conv_expr (&argse
, arg
);
2688 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
2689 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2690 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2691 len
= argse
.string_length
;
2694 se
->expr
= convert (type
, len
);
2697 /* The length of a character string not including trailing blanks. */
2699 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
2701 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
2702 tree args
[2], type
, fndecl
;
2704 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2705 type
= gfc_typenode_for_spec (&expr
->ts
);
2708 fndecl
= gfor_fndecl_string_len_trim
;
2710 fndecl
= gfor_fndecl_string_len_trim_char4
;
2714 se
->expr
= build_call_expr (fndecl
, 2, args
[0], args
[1]);
2715 se
->expr
= convert (type
, se
->expr
);
2719 /* Returns the starting position of a substring within a string. */
2722 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
2725 tree logical4_type_node
= gfc_get_logical_type (4);
2729 unsigned int num_args
;
2731 num_args
= gfc_intrinsic_argument_list_length (expr
);
2732 args
= alloca (sizeof (tree
) * 5);
2734 gfc_conv_intrinsic_function_args (se
, expr
, args
,
2735 num_args
>= 5 ? 5 : num_args
);
2736 type
= gfc_typenode_for_spec (&expr
->ts
);
2739 args
[4] = build_int_cst (logical4_type_node
, 0);
2741 args
[4] = convert (logical4_type_node
, args
[4]);
2743 fndecl
= build_addr (function
, current_function_decl
);
2744 se
->expr
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2746 se
->expr
= convert (type
, se
->expr
);
2750 /* The ascii value for a single character. */
2752 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
2754 tree args
[2], type
, pchartype
;
2756 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2757 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
2758 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
2759 args
[1] = fold_build1 (NOP_EXPR
, pchartype
, args
[1]);
2760 type
= gfc_typenode_for_spec (&expr
->ts
);
2762 se
->expr
= build_fold_indirect_ref (args
[1]);
2763 se
->expr
= convert (type
, se
->expr
);
2767 /* Intrinsic ISNAN calls __builtin_isnan. */
2770 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
2774 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2775 se
->expr
= build_call_expr (built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
2776 STRIP_TYPE_NOPS (se
->expr
);
2777 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2781 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
2782 their argument against a constant integer value. */
2785 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
2789 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2790 se
->expr
= fold_build2 (EQ_EXPR
, gfc_typenode_for_spec (&expr
->ts
),
2791 arg
, build_int_cst (TREE_TYPE (arg
), value
));
2796 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2799 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
2807 unsigned int num_args
;
2809 num_args
= gfc_intrinsic_argument_list_length (expr
);
2810 args
= alloca (sizeof (tree
) * num_args
);
2812 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2813 if (expr
->ts
.type
!= BT_CHARACTER
)
2821 /* We do the same as in the non-character case, but the argument
2822 list is different because of the string length arguments. We
2823 also have to set the string length for the result. */
2829 se
->string_length
= len
;
2831 type
= TREE_TYPE (tsource
);
2832 se
->expr
= fold_build3 (COND_EXPR
, type
, mask
, tsource
, fsource
);
2836 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
2838 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
2840 tree arg
, type
, tmp
;
2843 switch (expr
->ts
.kind
)
2846 frexp
= BUILT_IN_FREXPF
;
2849 frexp
= BUILT_IN_FREXP
;
2853 frexp
= BUILT_IN_FREXPL
;
2859 type
= gfc_typenode_for_spec (&expr
->ts
);
2860 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2861 tmp
= gfc_create_var (integer_type_node
, NULL
);
2862 se
->expr
= build_call_expr (built_in_decls
[frexp
], 2,
2863 fold_convert (type
, arg
),
2864 build_fold_addr_expr (tmp
));
2865 se
->expr
= fold_convert (type
, se
->expr
);
2869 /* NEAREST (s, dir) is translated into
2870 tmp = copysign (INF, dir);
2871 return nextafter (s, tmp);
2874 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
2876 tree args
[2], type
, tmp
;
2877 int nextafter
, copysign
, inf
;
2879 switch (expr
->ts
.kind
)
2882 nextafter
= BUILT_IN_NEXTAFTERF
;
2883 copysign
= BUILT_IN_COPYSIGNF
;
2884 inf
= BUILT_IN_INFF
;
2887 nextafter
= BUILT_IN_NEXTAFTER
;
2888 copysign
= BUILT_IN_COPYSIGN
;
2893 nextafter
= BUILT_IN_NEXTAFTERL
;
2894 copysign
= BUILT_IN_COPYSIGNL
;
2895 inf
= BUILT_IN_INFL
;
2901 type
= gfc_typenode_for_spec (&expr
->ts
);
2902 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2903 tmp
= build_call_expr (built_in_decls
[copysign
], 2,
2904 build_call_expr (built_in_decls
[inf
], 0),
2905 fold_convert (type
, args
[1]));
2906 se
->expr
= build_call_expr (built_in_decls
[nextafter
], 2,
2907 fold_convert (type
, args
[0]), tmp
);
2908 se
->expr
= fold_convert (type
, se
->expr
);
2912 /* SPACING (s) is translated into
2920 e = MAX_EXPR (e, emin);
2921 res = scalbn (1., e);
2925 where prec is the precision of s, gfc_real_kinds[k].digits,
2926 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
2927 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
2930 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
2932 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
2934 int frexp
, scalbn
, k
;
2937 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
2938 prec
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].digits
);
2939 emin
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].min_exponent
- 1);
2940 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
);
2942 switch (expr
->ts
.kind
)
2945 frexp
= BUILT_IN_FREXPF
;
2946 scalbn
= BUILT_IN_SCALBNF
;
2949 frexp
= BUILT_IN_FREXP
;
2950 scalbn
= BUILT_IN_SCALBN
;
2954 frexp
= BUILT_IN_FREXPL
;
2955 scalbn
= BUILT_IN_SCALBNL
;
2961 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2962 arg
= gfc_evaluate_now (arg
, &se
->pre
);
2964 type
= gfc_typenode_for_spec (&expr
->ts
);
2965 e
= gfc_create_var (integer_type_node
, NULL
);
2966 res
= gfc_create_var (type
, NULL
);
2969 /* Build the block for s /= 0. */
2970 gfc_start_block (&block
);
2971 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
2972 build_fold_addr_expr (e
));
2973 gfc_add_expr_to_block (&block
, tmp
);
2975 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, e
, prec
);
2976 gfc_add_modify_expr (&block
, e
, fold_build2 (MAX_EXPR
, integer_type_node
,
2979 tmp
= build_call_expr (built_in_decls
[scalbn
], 2,
2980 build_real_from_int_cst (type
, integer_one_node
), e
);
2981 gfc_add_modify_expr (&block
, res
, tmp
);
2983 /* Finish by building the IF statement. */
2984 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, arg
,
2985 build_real_from_int_cst (type
, integer_zero_node
));
2986 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
2987 gfc_finish_block (&block
));
2989 gfc_add_expr_to_block (&se
->pre
, tmp
);
2994 /* RRSPACING (s) is translated into
3001 x = scalbn (x, precision - e);
3005 where precision is gfc_real_kinds[k].digits. */
3008 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
3010 tree arg
, type
, e
, x
, cond
, stmt
, tmp
;
3011 int frexp
, scalbn
, fabs
, prec
, k
;
3014 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
3015 prec
= gfc_real_kinds
[k
].digits
;
3016 switch (expr
->ts
.kind
)
3019 frexp
= BUILT_IN_FREXPF
;
3020 scalbn
= BUILT_IN_SCALBNF
;
3021 fabs
= BUILT_IN_FABSF
;
3024 frexp
= BUILT_IN_FREXP
;
3025 scalbn
= BUILT_IN_SCALBN
;
3026 fabs
= BUILT_IN_FABS
;
3030 frexp
= BUILT_IN_FREXPL
;
3031 scalbn
= BUILT_IN_SCALBNL
;
3032 fabs
= BUILT_IN_FABSL
;
3038 type
= gfc_typenode_for_spec (&expr
->ts
);
3039 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3040 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3042 e
= gfc_create_var (integer_type_node
, NULL
);
3043 x
= gfc_create_var (type
, NULL
);
3044 gfc_add_modify_expr (&se
->pre
, x
,
3045 build_call_expr (built_in_decls
[fabs
], 1, arg
));
3048 gfc_start_block (&block
);
3049 tmp
= build_call_expr (built_in_decls
[frexp
], 2, arg
,
3050 build_fold_addr_expr (e
));
3051 gfc_add_expr_to_block (&block
, tmp
);
3053 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
,
3054 build_int_cst (NULL_TREE
, prec
), e
);
3055 tmp
= build_call_expr (built_in_decls
[scalbn
], 2, x
, tmp
);
3056 gfc_add_modify_expr (&block
, x
, tmp
);
3057 stmt
= gfc_finish_block (&block
);
3059 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, x
,
3060 build_real_from_int_cst (type
, integer_zero_node
));
3061 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt ());
3062 gfc_add_expr_to_block (&se
->pre
, tmp
);
3064 se
->expr
= fold_convert (type
, x
);
3068 /* SCALE (s, i) is translated into scalbn (s, i). */
3070 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
3075 switch (expr
->ts
.kind
)
3078 scalbn
= BUILT_IN_SCALBNF
;
3081 scalbn
= BUILT_IN_SCALBN
;
3085 scalbn
= BUILT_IN_SCALBNL
;
3091 type
= gfc_typenode_for_spec (&expr
->ts
);
3092 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3093 se
->expr
= build_call_expr (built_in_decls
[scalbn
], 2,
3094 fold_convert (type
, args
[0]),
3095 fold_convert (integer_type_node
, args
[1]));
3096 se
->expr
= fold_convert (type
, se
->expr
);
3100 /* SET_EXPONENT (s, i) is translated into
3101 scalbn (frexp (s, &dummy_int), i). */
3103 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
3105 tree args
[2], type
, tmp
;
3108 switch (expr
->ts
.kind
)
3111 frexp
= BUILT_IN_FREXPF
;
3112 scalbn
= BUILT_IN_SCALBNF
;
3115 frexp
= BUILT_IN_FREXP
;
3116 scalbn
= BUILT_IN_SCALBN
;
3120 frexp
= BUILT_IN_FREXPL
;
3121 scalbn
= BUILT_IN_SCALBNL
;
3127 type
= gfc_typenode_for_spec (&expr
->ts
);
3128 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3130 tmp
= gfc_create_var (integer_type_node
, NULL
);
3131 tmp
= build_call_expr (built_in_decls
[frexp
], 2,
3132 fold_convert (type
, args
[0]),
3133 build_fold_addr_expr (tmp
));
3134 se
->expr
= build_call_expr (built_in_decls
[scalbn
], 2, tmp
,
3135 fold_convert (integer_type_node
, args
[1]));
3136 se
->expr
= fold_convert (type
, se
->expr
);
3141 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
3143 gfc_actual_arglist
*actual
;
3151 gfc_init_se (&argse
, NULL
);
3152 actual
= expr
->value
.function
.actual
;
3154 ss
= gfc_walk_expr (actual
->expr
);
3155 gcc_assert (ss
!= gfc_ss_terminator
);
3156 argse
.want_pointer
= 1;
3157 argse
.data_not_needed
= 1;
3158 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
3159 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3160 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3161 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
3163 /* Build the call to size0. */
3164 fncall0
= build_call_expr (gfor_fndecl_size0
, 1, arg1
);
3166 actual
= actual
->next
;
3170 gfc_init_se (&argse
, NULL
);
3171 gfc_conv_expr_type (&argse
, actual
->expr
,
3172 gfc_array_index_type
);
3173 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3175 /* Build the call to size1. */
3176 fncall1
= build_call_expr (gfor_fndecl_size1
, 2,
3179 /* Unusually, for an intrinsic, size does not exclude
3180 an optional arg2, so we must test for it. */
3181 if (actual
->expr
->expr_type
== EXPR_VARIABLE
3182 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
3183 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
3186 gfc_init_se (&argse
, NULL
);
3187 argse
.want_pointer
= 1;
3188 argse
.data_not_needed
= 1;
3189 gfc_conv_expr (&argse
, actual
->expr
);
3190 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3191 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3192 argse
.expr
, null_pointer_node
);
3193 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3194 se
->expr
= fold_build3 (COND_EXPR
, pvoid_type_node
,
3195 tmp
, fncall1
, fncall0
);
3203 type
= gfc_typenode_for_spec (&expr
->ts
);
3204 se
->expr
= convert (type
, se
->expr
);
3209 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
3223 arg
= expr
->value
.function
.actual
->expr
;
3225 gfc_init_se (&argse
, NULL
);
3226 ss
= gfc_walk_expr (arg
);
3228 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
3230 if (ss
== gfc_ss_terminator
)
3232 gfc_conv_expr_reference (&argse
, arg
);
3233 source
= argse
.expr
;
3235 type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3237 /* Obtain the source word length. */
3238 if (arg
->ts
.type
== BT_CHARACTER
)
3239 source_bytes
= fold_convert (gfc_array_index_type
,
3240 argse
.string_length
);
3242 source_bytes
= fold_convert (gfc_array_index_type
,
3243 size_in_bytes (type
));
3247 argse
.want_pointer
= 0;
3248 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3249 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3250 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3252 /* Obtain the argument's word length. */
3253 if (arg
->ts
.type
== BT_CHARACTER
)
3254 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3256 tmp
= fold_convert (gfc_array_index_type
,
3257 size_in_bytes (type
));
3258 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3260 /* Obtain the size of the array in bytes. */
3261 for (n
= 0; n
< arg
->rank
; n
++)
3264 idx
= gfc_rank_cst
[n
];
3265 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3266 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3267 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3269 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3270 tmp
, gfc_index_one_node
);
3271 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3273 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3277 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3278 se
->expr
= source_bytes
;
3282 /* Intrinsic string comparison functions. */
3285 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, int op
)
3289 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
3292 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
3293 expr
->value
.function
.actual
->expr
->ts
.kind
);
3294 se
->expr
= fold_build2 (op
, gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
3295 build_int_cst (TREE_TYPE (se
->expr
), 0));
3298 /* Generate a call to the adjustl/adjustr library function. */
3300 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
3308 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
3311 type
= TREE_TYPE (args
[2]);
3312 var
= gfc_conv_string_tmp (se
, type
, len
);
3315 tmp
= build_call_expr (fndecl
, 3, args
[0], args
[1], args
[2]);
3316 gfc_add_expr_to_block (&se
->pre
, tmp
);
3318 se
->string_length
= len
;
3322 /* Array transfer statement.
3323 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3325 typeof<DEST> = typeof<MOLD>
3327 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3328 sizeof (DEST(0) * SIZE). */
3331 gfc_conv_intrinsic_array_transfer (gfc_se
* se
, gfc_expr
* expr
)
3346 gfc_actual_arglist
*arg
;
3353 gcc_assert (se
->loop
);
3354 info
= &se
->ss
->data
.info
;
3356 /* Convert SOURCE. The output from this stage is:-
3357 source_bytes = length of the source in bytes
3358 source = pointer to the source data. */
3359 arg
= expr
->value
.function
.actual
;
3360 gfc_init_se (&argse
, NULL
);
3361 ss
= gfc_walk_expr (arg
->expr
);
3363 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3365 /* Obtain the pointer to source and the length of source in bytes. */
3366 if (ss
== gfc_ss_terminator
)
3368 gfc_conv_expr_reference (&argse
, arg
->expr
);
3369 source
= argse
.expr
;
3371 source_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3373 /* Obtain the source word length. */
3374 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3375 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3377 tmp
= fold_convert (gfc_array_index_type
,
3378 size_in_bytes (source_type
));
3382 argse
.want_pointer
= 0;
3383 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3384 source
= gfc_conv_descriptor_data_get (argse
.expr
);
3385 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3387 /* Repack the source if not a full variable array. */
3388 if (!(arg
->expr
->expr_type
== EXPR_VARIABLE
3389 && arg
->expr
->ref
->u
.ar
.type
== AR_FULL
))
3391 tmp
= build_fold_addr_expr (argse
.expr
);
3392 source
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
3393 source
= gfc_evaluate_now (source
, &argse
.pre
);
3395 /* Free the temporary. */
3396 gfc_start_block (&block
);
3397 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
3398 gfc_add_expr_to_block (&block
, tmp
);
3399 stmt
= gfc_finish_block (&block
);
3401 /* Clean up if it was repacked. */
3402 gfc_init_block (&block
);
3403 tmp
= gfc_conv_array_data (argse
.expr
);
3404 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, source
, tmp
);
3405 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3406 gfc_add_expr_to_block (&block
, tmp
);
3407 gfc_add_block_to_block (&block
, &se
->post
);
3408 gfc_init_block (&se
->post
);
3409 gfc_add_block_to_block (&se
->post
, &block
);
3412 /* Obtain the source word length. */
3413 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3414 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3416 tmp
= fold_convert (gfc_array_index_type
,
3417 size_in_bytes (source_type
));
3419 /* Obtain the size of the array in bytes. */
3420 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
3421 for (n
= 0; n
< arg
->expr
->rank
; n
++)
3424 idx
= gfc_rank_cst
[n
];
3425 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3426 stride
= gfc_conv_descriptor_stride (argse
.expr
, idx
);
3427 lower
= gfc_conv_descriptor_lbound (argse
.expr
, idx
);
3428 upper
= gfc_conv_descriptor_ubound (argse
.expr
, idx
);
3429 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3431 gfc_add_modify_expr (&argse
.pre
, extent
, tmp
);
3432 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3433 extent
, gfc_index_one_node
);
3434 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3439 gfc_add_modify_expr (&argse
.pre
, source_bytes
, tmp
);
3440 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3441 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3443 /* Now convert MOLD. The outputs are:
3444 mold_type = the TREE type of MOLD
3445 dest_word_len = destination word length in bytes. */
3448 gfc_init_se (&argse
, NULL
);
3449 ss
= gfc_walk_expr (arg
->expr
);
3451 if (ss
== gfc_ss_terminator
)
3453 gfc_conv_expr_reference (&argse
, arg
->expr
);
3454 mold_type
= TREE_TYPE (build_fold_indirect_ref (argse
.expr
));
3458 gfc_init_se (&argse
, NULL
);
3459 argse
.want_pointer
= 0;
3460 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
3461 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
3464 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
3466 tmp
= fold_convert (gfc_array_index_type
, argse
.string_length
);
3467 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
3470 tmp
= fold_convert (gfc_array_index_type
,
3471 size_in_bytes (mold_type
));
3473 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
3474 gfc_add_modify_expr (&se
->pre
, dest_word_len
, tmp
);
3476 /* Finally convert SIZE, if it is present. */
3478 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
3482 gfc_init_se (&argse
, NULL
);
3483 gfc_conv_expr_reference (&argse
, arg
->expr
);
3484 tmp
= convert (gfc_array_index_type
,
3485 build_fold_indirect_ref (argse
.expr
));
3486 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3487 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3492 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
3493 if (tmp
!= NULL_TREE
)
3495 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3496 tmp
, dest_word_len
);
3497 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3503 gfc_add_modify_expr (&se
->pre
, size_bytes
, tmp
);
3504 gfc_add_modify_expr (&se
->pre
, size_words
,
3505 fold_build2 (CEIL_DIV_EXPR
, gfc_array_index_type
,
3506 size_bytes
, dest_word_len
));
3508 /* Evaluate the bounds of the result. If the loop range exists, we have
3509 to check if it is too large. If so, we modify loop->to be consistent
3510 with min(size, size(source)). Otherwise, size is made consistent with
3511 the loop range, so that the right number of bytes is transferred.*/
3512 n
= se
->loop
->order
[0];
3513 if (se
->loop
->to
[n
] != NULL_TREE
)
3515 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3516 se
->loop
->to
[n
], se
->loop
->from
[n
]);
3517 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3518 tmp
, gfc_index_one_node
);
3519 tmp
= fold_build2 (MIN_EXPR
, gfc_array_index_type
,
3521 gfc_add_modify_expr (&se
->pre
, size_words
, tmp
);
3522 gfc_add_modify_expr (&se
->pre
, size_bytes
,
3523 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3524 size_words
, dest_word_len
));
3525 upper
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3526 size_words
, se
->loop
->from
[n
]);
3527 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3528 upper
, gfc_index_one_node
);
3532 upper
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3533 size_words
, gfc_index_one_node
);
3534 se
->loop
->from
[n
] = gfc_index_zero_node
;
3537 se
->loop
->to
[n
] = upper
;
3539 /* Build a destination descriptor, using the pointer, source, as the
3540 data field. This is already allocated so set callee_alloc.
3541 FIXME callee_alloc is not set! */
3543 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
3544 info
, mold_type
, false, true, false);
3546 /* Cast the pointer to the result. */
3547 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3548 tmp
= fold_convert (pvoid_type_node
, tmp
);
3550 /* Use memcpy to do the transfer. */
3551 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
],
3554 fold_convert (pvoid_type_node
, source
),
3556 gfc_add_expr_to_block (&se
->pre
, tmp
);
3558 se
->expr
= info
->descriptor
;
3559 if (expr
->ts
.type
== BT_CHARACTER
)
3560 se
->string_length
= dest_word_len
;
3564 /* Scalar transfer statement.
3565 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3568 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
3570 gfc_actual_arglist
*arg
;
3577 /* Get a pointer to the source. */
3578 arg
= expr
->value
.function
.actual
;
3579 ss
= gfc_walk_expr (arg
->expr
);
3580 gfc_init_se (&argse
, NULL
);
3581 if (ss
== gfc_ss_terminator
)
3582 gfc_conv_expr_reference (&argse
, arg
->expr
);
3584 gfc_conv_array_parameter (&argse
, arg
->expr
, ss
, 1);
3585 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3586 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3590 type
= gfc_typenode_for_spec (&expr
->ts
);
3592 if (expr
->ts
.type
== BT_CHARACTER
)
3594 ptr
= convert (build_pointer_type (type
), ptr
);
3595 gfc_init_se (&argse
, NULL
);
3596 gfc_conv_expr (&argse
, arg
->expr
);
3597 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3598 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3600 se
->string_length
= argse
.string_length
;
3605 tmpdecl
= gfc_create_var (type
, "transfer");
3606 moldsize
= size_in_bytes (type
);
3608 /* Use memcpy to do the transfer. */
3609 tmp
= fold_build1 (ADDR_EXPR
, build_pointer_type (type
), tmpdecl
);
3610 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
3611 fold_convert (pvoid_type_node
, tmp
),
3612 fold_convert (pvoid_type_node
, ptr
),
3614 gfc_add_expr_to_block (&se
->pre
, tmp
);
3621 /* Generate code for the ALLOCATED intrinsic.
3622 Generate inline code that directly check the address of the argument. */
3625 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
3627 gfc_actual_arglist
*arg1
;
3632 gfc_init_se (&arg1se
, NULL
);
3633 arg1
= expr
->value
.function
.actual
;
3634 ss1
= gfc_walk_expr (arg1
->expr
);
3635 arg1se
.descriptor_only
= 1;
3636 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3638 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3639 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3640 tmp
, fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
3641 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
3645 /* Generate code for the ASSOCIATED intrinsic.
3646 If both POINTER and TARGET are arrays, generate a call to library function
3647 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3648 In other cases, generate inline code that directly compare the address of
3649 POINTER with the address of TARGET. */
3652 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
3654 gfc_actual_arglist
*arg1
;
3655 gfc_actual_arglist
*arg2
;
3660 tree nonzero_charlen
;
3661 tree nonzero_arraylen
;
3664 gfc_init_se (&arg1se
, NULL
);
3665 gfc_init_se (&arg2se
, NULL
);
3666 arg1
= expr
->value
.function
.actual
;
3668 ss1
= gfc_walk_expr (arg1
->expr
);
3672 /* No optional target. */
3673 if (ss1
== gfc_ss_terminator
)
3675 /* A pointer to a scalar. */
3676 arg1se
.want_pointer
= 1;
3677 gfc_conv_expr (&arg1se
, arg1
->expr
);
3682 /* A pointer to an array. */
3683 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3684 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
3686 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3687 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3688 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp2
,
3689 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
3694 /* An optional target. */
3695 ss2
= gfc_walk_expr (arg2
->expr
);
3697 nonzero_charlen
= NULL_TREE
;
3698 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
3699 nonzero_charlen
= fold_build2 (NE_EXPR
, boolean_type_node
,
3700 arg1
->expr
->ts
.cl
->backend_decl
,
3703 if (ss1
== gfc_ss_terminator
)
3705 /* A pointer to a scalar. */
3706 gcc_assert (ss2
== gfc_ss_terminator
);
3707 arg1se
.want_pointer
= 1;
3708 gfc_conv_expr (&arg1se
, arg1
->expr
);
3709 arg2se
.want_pointer
= 1;
3710 gfc_conv_expr (&arg2se
, arg2
->expr
);
3711 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3712 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3713 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3714 arg1se
.expr
, arg2se
.expr
);
3715 tmp2
= fold_build2 (NE_EXPR
, boolean_type_node
,
3716 arg1se
.expr
, null_pointer_node
);
3717 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3722 /* An array pointer of zero length is not associated if target is
3724 arg1se
.descriptor_only
= 1;
3725 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
3726 tmp
= gfc_conv_descriptor_stride (arg1se
.expr
,
3727 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
3728 nonzero_arraylen
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
3729 build_int_cst (TREE_TYPE (tmp
), 0));
3731 /* A pointer to an array, call library function _gfor_associated. */
3732 gcc_assert (ss2
!= gfc_ss_terminator
);
3733 arg1se
.want_pointer
= 1;
3734 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
3736 arg2se
.want_pointer
= 1;
3737 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
3738 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3739 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3740 se
->expr
= build_call_expr (gfor_fndecl_associated
, 2,
3741 arg1se
.expr
, arg2se
.expr
);
3742 se
->expr
= convert (boolean_type_node
, se
->expr
);
3743 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3744 se
->expr
, nonzero_arraylen
);
3747 /* If target is present zero character length pointers cannot
3749 if (nonzero_charlen
!= NULL_TREE
)
3750 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3751 se
->expr
, nonzero_charlen
);
3754 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3758 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
3761 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
3765 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3766 se
->expr
= build_call_expr (gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
3767 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3771 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3774 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
3778 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3780 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
3781 type
= gfc_get_int_type (4);
3782 arg
= build_fold_addr_expr (fold_convert (type
, arg
));
3784 /* Convert it to the required type. */
3785 type
= gfc_typenode_for_spec (&expr
->ts
);
3786 se
->expr
= build_call_expr (gfor_fndecl_si_kind
, 1, arg
);
3787 se
->expr
= fold_convert (type
, se
->expr
);
3791 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3794 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
3796 gfc_actual_arglist
*actual
;
3801 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3803 gfc_init_se (&argse
, se
);
3805 /* Pass a NULL pointer for an absent arg. */
3806 if (actual
->expr
== NULL
)
3807 argse
.expr
= null_pointer_node
;
3813 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3815 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
3816 ts
.type
= BT_INTEGER
;
3817 ts
.kind
= gfc_c_int_kind
;
3818 gfc_convert_type (actual
->expr
, &ts
, 2);
3820 gfc_conv_expr_reference (&argse
, actual
->expr
);
3823 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3824 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3825 args
= gfc_chainon_list (args
, argse
.expr
);
3828 /* Convert it to the required type. */
3829 type
= gfc_typenode_for_spec (&expr
->ts
);
3830 se
->expr
= build_function_call_expr (gfor_fndecl_sr_kind
, args
);
3831 se
->expr
= fold_convert (type
, se
->expr
);
3835 /* Generate code for TRIM (A) intrinsic function. */
3838 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
3840 tree gfc_int4_type_node
= gfc_get_int_type (4);
3850 unsigned int num_args
;
3852 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3853 args
= alloca (sizeof (tree
) * num_args
);
3855 type
= build_pointer_type (gfc_character1_type_node
);
3856 var
= gfc_create_var (type
, "pstr");
3857 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
3858 len
= gfc_create_var (gfc_int4_type_node
, "len");
3860 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3861 args
[0] = build_fold_addr_expr (len
);
3864 if (expr
->ts
.kind
== 1)
3865 function
= gfor_fndecl_string_trim
;
3866 else if (expr
->ts
.kind
== 4)
3867 function
= gfor_fndecl_string_trim_char4
;
3871 fndecl
= build_addr (function
, current_function_decl
);
3872 tmp
= build_call_array (TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3874 gfc_add_expr_to_block (&se
->pre
, tmp
);
3876 /* Free the temporary afterwards, if necessary. */
3877 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
3878 len
, build_int_cst (TREE_TYPE (len
), 0));
3879 tmp
= gfc_call_free (var
);
3880 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
3881 gfc_add_expr_to_block (&se
->post
, tmp
);
3884 se
->string_length
= len
;
3888 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3891 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
3893 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
3894 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
3895 stmtblock_t block
, body
;
3898 /* Get the arguments. */
3899 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3900 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
3902 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
3903 ncopies_type
= TREE_TYPE (ncopies
);
3905 /* Check that NCOPIES is not negative. */
3906 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, ncopies
,
3907 build_int_cst (ncopies_type
, 0));
3908 gfc_trans_runtime_check (cond
, &se
->pre
, &expr
->where
,
3909 "Argument NCOPIES of REPEAT intrinsic is negative "
3910 "(its value is %lld)",
3911 fold_convert (long_integer_type_node
, ncopies
));
3913 /* If the source length is zero, any non negative value of NCOPIES
3914 is valid, and nothing happens. */
3915 n
= gfc_create_var (ncopies_type
, "ncopies");
3916 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
3917 build_int_cst (size_type_node
, 0));
3918 tmp
= fold_build3 (COND_EXPR
, ncopies_type
, cond
,
3919 build_int_cst (ncopies_type
, 0), ncopies
);
3920 gfc_add_modify_expr (&se
->pre
, n
, tmp
);
3923 /* Check that ncopies is not too large: ncopies should be less than
3924 (or equal to) MAX / slen, where MAX is the maximal integer of
3925 the gfc_charlen_type_node type. If slen == 0, we need a special
3926 case to avoid the division by zero. */
3927 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
3928 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
3929 max
= fold_build2 (TRUNC_DIV_EXPR
, size_type_node
,
3930 fold_convert (size_type_node
, max
), slen
);
3931 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
3932 ? size_type_node
: ncopies_type
;
3933 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
3934 fold_convert (largest
, ncopies
),
3935 fold_convert (largest
, max
));
3936 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, slen
,
3937 build_int_cst (size_type_node
, 0));
3938 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
, boolean_false_node
,
3940 gfc_trans_runtime_check (cond
, &se
->pre
, &expr
->where
,
3941 "Argument NCOPIES of REPEAT intrinsic is too large");
3944 /* Compute the destination length. */
3945 dlen
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
3946 fold_convert (gfc_charlen_type_node
, slen
),
3947 fold_convert (gfc_charlen_type_node
, ncopies
));
3948 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
3949 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
3951 /* Generate the code to do the repeat operation:
3952 for (i = 0; i < ncopies; i++)
3953 memmove (dest + (i * slen), src, slen); */
3954 gfc_start_block (&block
);
3955 count
= gfc_create_var (ncopies_type
, "count");
3956 gfc_add_modify_expr (&block
, count
, build_int_cst (ncopies_type
, 0));
3957 exit_label
= gfc_build_label_decl (NULL_TREE
);
3959 /* Start the loop body. */
3960 gfc_start_block (&body
);
3962 /* Exit the loop if count >= ncopies. */
3963 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, count
, ncopies
);
3964 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3965 TREE_USED (exit_label
) = 1;
3966 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3967 build_empty_stmt ());
3968 gfc_add_expr_to_block (&body
, tmp
);
3970 /* Call memmove (dest + (i*slen), src, slen). */
3971 tmp
= fold_build2 (MULT_EXPR
, gfc_charlen_type_node
,
3972 fold_convert (gfc_charlen_type_node
, slen
),
3973 fold_convert (gfc_charlen_type_node
, count
));
3974 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
,
3975 fold_convert (pchar_type_node
, dest
),
3976 fold_convert (sizetype
, tmp
));
3977 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], 3,
3979 gfc_add_expr_to_block (&body
, tmp
);
3981 /* Increment count. */
3982 tmp
= fold_build2 (PLUS_EXPR
, ncopies_type
,
3983 count
, build_int_cst (TREE_TYPE (count
), 1));
3984 gfc_add_modify_expr (&body
, count
, tmp
);
3986 /* Build the loop. */
3987 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
3988 gfc_add_expr_to_block (&block
, tmp
);
3990 /* Add the exit label. */
3991 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3992 gfc_add_expr_to_block (&block
, tmp
);
3994 /* Finish the block. */
3995 tmp
= gfc_finish_block (&block
);
3996 gfc_add_expr_to_block (&se
->pre
, tmp
);
3998 /* Set the result value. */
4000 se
->string_length
= dlen
;
4004 /* Generate code for the IARGC intrinsic. */
4007 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
4013 /* Call the library function. This always returns an INTEGER(4). */
4014 fndecl
= gfor_fndecl_iargc
;
4015 tmp
= build_call_expr (fndecl
, 0);
4017 /* Convert it to the required type. */
4018 type
= gfc_typenode_for_spec (&expr
->ts
);
4019 tmp
= fold_convert (type
, tmp
);
4025 /* The loc intrinsic returns the address of its argument as
4026 gfc_index_integer_kind integer. */
4029 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
4035 gcc_assert (!se
->ss
);
4037 arg_expr
= expr
->value
.function
.actual
->expr
;
4038 ss
= gfc_walk_expr (arg_expr
);
4039 if (ss
== gfc_ss_terminator
)
4040 gfc_conv_expr_reference (se
, arg_expr
);
4042 gfc_conv_array_parameter (se
, arg_expr
, ss
, 1);
4043 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
4045 /* Create a temporary variable for loc return value. Without this,
4046 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4047 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
4048 gfc_add_modify_expr (&se
->pre
, temp_var
, se
->expr
);
4049 se
->expr
= temp_var
;
4052 /* Generate code for an intrinsic function. Some map directly to library
4053 calls, others get special handling. In some cases the name of the function
4054 used depends on the type specifiers. */
4057 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
4059 gfc_intrinsic_sym
*isym
;
4064 isym
= expr
->value
.function
.isym
;
4066 name
= &expr
->value
.function
.name
[2];
4068 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
4070 lib
= gfc_is_intrinsic_libcall (expr
);
4074 se
->ignore_optional
= 1;
4075 gfc_conv_intrinsic_funcall (se
, expr
);
4080 switch (expr
->value
.function
.isym
->id
)
4085 case GFC_ISYM_REPEAT
:
4086 gfc_conv_intrinsic_repeat (se
, expr
);
4090 gfc_conv_intrinsic_trim (se
, expr
);
4093 case GFC_ISYM_SC_KIND
:
4094 gfc_conv_intrinsic_sc_kind (se
, expr
);
4097 case GFC_ISYM_SI_KIND
:
4098 gfc_conv_intrinsic_si_kind (se
, expr
);
4101 case GFC_ISYM_SR_KIND
:
4102 gfc_conv_intrinsic_sr_kind (se
, expr
);
4105 case GFC_ISYM_EXPONENT
:
4106 gfc_conv_intrinsic_exponent (se
, expr
);
4110 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4112 fndecl
= gfor_fndecl_string_scan
;
4114 fndecl
= gfor_fndecl_string_scan_char4
;
4118 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4121 case GFC_ISYM_VERIFY
:
4122 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4124 fndecl
= gfor_fndecl_string_verify
;
4126 fndecl
= gfor_fndecl_string_verify_char4
;
4130 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4133 case GFC_ISYM_ALLOCATED
:
4134 gfc_conv_allocated (se
, expr
);
4137 case GFC_ISYM_ASSOCIATED
:
4138 gfc_conv_associated(se
, expr
);
4142 gfc_conv_intrinsic_abs (se
, expr
);
4145 case GFC_ISYM_ADJUSTL
:
4146 if (expr
->ts
.kind
== 1)
4147 fndecl
= gfor_fndecl_adjustl
;
4148 else if (expr
->ts
.kind
== 4)
4149 fndecl
= gfor_fndecl_adjustl_char4
;
4153 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
4156 case GFC_ISYM_ADJUSTR
:
4157 if (expr
->ts
.kind
== 1)
4158 fndecl
= gfor_fndecl_adjustr
;
4159 else if (expr
->ts
.kind
== 4)
4160 fndecl
= gfor_fndecl_adjustr_char4
;
4164 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
4167 case GFC_ISYM_AIMAG
:
4168 gfc_conv_intrinsic_imagpart (se
, expr
);
4172 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
4176 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
4179 case GFC_ISYM_ANINT
:
4180 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
4184 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
4188 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
4191 case GFC_ISYM_BTEST
:
4192 gfc_conv_intrinsic_btest (se
, expr
);
4195 case GFC_ISYM_ACHAR
:
4197 gfc_conv_intrinsic_char (se
, expr
);
4200 case GFC_ISYM_CONVERSION
:
4202 case GFC_ISYM_LOGICAL
:
4204 gfc_conv_intrinsic_conversion (se
, expr
);
4207 /* Integer conversions are handled separately to make sure we get the
4208 correct rounding mode. */
4213 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
4217 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
4220 case GFC_ISYM_CEILING
:
4221 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
4224 case GFC_ISYM_FLOOR
:
4225 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
4229 gfc_conv_intrinsic_mod (se
, expr
, 0);
4232 case GFC_ISYM_MODULO
:
4233 gfc_conv_intrinsic_mod (se
, expr
, 1);
4236 case GFC_ISYM_CMPLX
:
4237 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
4240 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
4241 gfc_conv_intrinsic_iargc (se
, expr
);
4244 case GFC_ISYM_COMPLEX
:
4245 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
4248 case GFC_ISYM_CONJG
:
4249 gfc_conv_intrinsic_conjg (se
, expr
);
4252 case GFC_ISYM_COUNT
:
4253 gfc_conv_intrinsic_count (se
, expr
);
4256 case GFC_ISYM_CTIME
:
4257 gfc_conv_intrinsic_ctime (se
, expr
);
4261 gfc_conv_intrinsic_dim (se
, expr
);
4264 case GFC_ISYM_DOT_PRODUCT
:
4265 gfc_conv_intrinsic_dot_product (se
, expr
);
4268 case GFC_ISYM_DPROD
:
4269 gfc_conv_intrinsic_dprod (se
, expr
);
4272 case GFC_ISYM_FDATE
:
4273 gfc_conv_intrinsic_fdate (se
, expr
);
4276 case GFC_ISYM_FRACTION
:
4277 gfc_conv_intrinsic_fraction (se
, expr
);
4281 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
4284 case GFC_ISYM_IBCLR
:
4285 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
4288 case GFC_ISYM_IBITS
:
4289 gfc_conv_intrinsic_ibits (se
, expr
);
4292 case GFC_ISYM_IBSET
:
4293 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
4296 case GFC_ISYM_IACHAR
:
4297 case GFC_ISYM_ICHAR
:
4298 /* We assume ASCII character sequence. */
4299 gfc_conv_intrinsic_ichar (se
, expr
);
4302 case GFC_ISYM_IARGC
:
4303 gfc_conv_intrinsic_iargc (se
, expr
);
4307 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4310 case GFC_ISYM_INDEX
:
4311 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4313 fndecl
= gfor_fndecl_string_index
;
4315 fndecl
= gfor_fndecl_string_index_char4
;
4319 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
4323 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4326 case GFC_ISYM_IS_IOSTAT_END
:
4327 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
4330 case GFC_ISYM_IS_IOSTAT_EOR
:
4331 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
4334 case GFC_ISYM_ISNAN
:
4335 gfc_conv_intrinsic_isnan (se
, expr
);
4338 case GFC_ISYM_LSHIFT
:
4339 gfc_conv_intrinsic_rlshift (se
, expr
, 0);
4342 case GFC_ISYM_RSHIFT
:
4343 gfc_conv_intrinsic_rlshift (se
, expr
, 1);
4346 case GFC_ISYM_ISHFT
:
4347 gfc_conv_intrinsic_ishft (se
, expr
);
4350 case GFC_ISYM_ISHFTC
:
4351 gfc_conv_intrinsic_ishftc (se
, expr
);
4354 case GFC_ISYM_LBOUND
:
4355 gfc_conv_intrinsic_bound (se
, expr
, 0);
4358 case GFC_ISYM_TRANSPOSE
:
4359 if (se
->ss
&& se
->ss
->useflags
)
4361 gfc_conv_tmp_array_ref (se
);
4362 gfc_advance_se_ss_chain (se
);
4365 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
4369 gfc_conv_intrinsic_len (se
, expr
);
4372 case GFC_ISYM_LEN_TRIM
:
4373 gfc_conv_intrinsic_len_trim (se
, expr
);
4377 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
4381 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
4385 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
4389 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
4393 if (expr
->ts
.type
== BT_CHARACTER
)
4394 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
4396 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
4399 case GFC_ISYM_MAXLOC
:
4400 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
4403 case GFC_ISYM_MAXVAL
:
4404 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
4407 case GFC_ISYM_MERGE
:
4408 gfc_conv_intrinsic_merge (se
, expr
);
4412 if (expr
->ts
.type
== BT_CHARACTER
)
4413 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
4415 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
4418 case GFC_ISYM_MINLOC
:
4419 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
4422 case GFC_ISYM_MINVAL
:
4423 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
4426 case GFC_ISYM_NEAREST
:
4427 gfc_conv_intrinsic_nearest (se
, expr
);
4431 gfc_conv_intrinsic_not (se
, expr
);
4435 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
4438 case GFC_ISYM_PRESENT
:
4439 gfc_conv_intrinsic_present (se
, expr
);
4442 case GFC_ISYM_PRODUCT
:
4443 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
);
4446 case GFC_ISYM_RRSPACING
:
4447 gfc_conv_intrinsic_rrspacing (se
, expr
);
4450 case GFC_ISYM_SET_EXPONENT
:
4451 gfc_conv_intrinsic_set_exponent (se
, expr
);
4454 case GFC_ISYM_SCALE
:
4455 gfc_conv_intrinsic_scale (se
, expr
);
4459 gfc_conv_intrinsic_sign (se
, expr
);
4463 gfc_conv_intrinsic_size (se
, expr
);
4466 case GFC_ISYM_SIZEOF
:
4467 gfc_conv_intrinsic_sizeof (se
, expr
);
4470 case GFC_ISYM_SPACING
:
4471 gfc_conv_intrinsic_spacing (se
, expr
);
4475 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
);
4478 case GFC_ISYM_TRANSFER
:
4481 if (se
->ss
->useflags
)
4483 /* Access the previously obtained result. */
4484 gfc_conv_tmp_array_ref (se
);
4485 gfc_advance_se_ss_chain (se
);
4489 gfc_conv_intrinsic_array_transfer (se
, expr
);
4492 gfc_conv_intrinsic_transfer (se
, expr
);
4495 case GFC_ISYM_TTYNAM
:
4496 gfc_conv_intrinsic_ttynam (se
, expr
);
4499 case GFC_ISYM_UBOUND
:
4500 gfc_conv_intrinsic_bound (se
, expr
, 1);
4504 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
4508 gfc_conv_intrinsic_loc (se
, expr
);
4511 case GFC_ISYM_ACCESS
:
4512 case GFC_ISYM_CHDIR
:
4513 case GFC_ISYM_CHMOD
:
4514 case GFC_ISYM_DTIME
:
4515 case GFC_ISYM_ETIME
:
4517 case GFC_ISYM_FGETC
:
4520 case GFC_ISYM_FPUTC
:
4521 case GFC_ISYM_FSTAT
:
4522 case GFC_ISYM_FTELL
:
4523 case GFC_ISYM_GETCWD
:
4524 case GFC_ISYM_GETGID
:
4525 case GFC_ISYM_GETPID
:
4526 case GFC_ISYM_GETUID
:
4527 case GFC_ISYM_HOSTNM
:
4529 case GFC_ISYM_IERRNO
:
4530 case GFC_ISYM_IRAND
:
4531 case GFC_ISYM_ISATTY
:
4533 case GFC_ISYM_LSTAT
:
4534 case GFC_ISYM_MALLOC
:
4535 case GFC_ISYM_MATMUL
:
4536 case GFC_ISYM_MCLOCK
:
4537 case GFC_ISYM_MCLOCK8
:
4539 case GFC_ISYM_RENAME
:
4540 case GFC_ISYM_SECOND
:
4541 case GFC_ISYM_SECNDS
:
4542 case GFC_ISYM_SIGNAL
:
4544 case GFC_ISYM_SYMLNK
:
4545 case GFC_ISYM_SYSTEM
:
4547 case GFC_ISYM_TIME8
:
4548 case GFC_ISYM_UMASK
:
4549 case GFC_ISYM_UNLINK
:
4550 gfc_conv_intrinsic_funcall (se
, expr
);
4554 gfc_conv_intrinsic_lib_function (se
, expr
);
4560 /* This generates code to execute before entering the scalarization loop.
4561 Currently does nothing. */
4564 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
4566 switch (ss
->expr
->value
.function
.isym
->id
)
4568 case GFC_ISYM_UBOUND
:
4569 case GFC_ISYM_LBOUND
:
4578 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4579 inside the scalarization loop. */
4582 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
4586 /* The two argument version returns a scalar. */
4587 if (expr
->value
.function
.actual
->next
->expr
)
4590 newss
= gfc_get_ss ();
4591 newss
->type
= GFC_SS_INTRINSIC
;
4594 newss
->data
.info
.dimen
= 1;
4600 /* Walk an intrinsic array libcall. */
4603 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
4607 gcc_assert (expr
->rank
> 0);
4609 newss
= gfc_get_ss ();
4610 newss
->type
= GFC_SS_FUNCTION
;
4613 newss
->data
.info
.dimen
= expr
->rank
;
4619 /* Returns nonzero if the specified intrinsic function call maps directly to a
4620 an external library call. Should only be used for functions that return
4624 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
4626 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
4627 gcc_assert (expr
->rank
> 0);
4629 switch (expr
->value
.function
.isym
->id
)
4633 case GFC_ISYM_COUNT
:
4634 case GFC_ISYM_MATMUL
:
4635 case GFC_ISYM_MAXLOC
:
4636 case GFC_ISYM_MAXVAL
:
4637 case GFC_ISYM_MINLOC
:
4638 case GFC_ISYM_MINVAL
:
4639 case GFC_ISYM_PRODUCT
:
4641 case GFC_ISYM_SHAPE
:
4642 case GFC_ISYM_SPREAD
:
4643 case GFC_ISYM_TRANSPOSE
:
4644 /* Ignore absent optional parameters. */
4647 case GFC_ISYM_RESHAPE
:
4648 case GFC_ISYM_CSHIFT
:
4649 case GFC_ISYM_EOSHIFT
:
4651 case GFC_ISYM_UNPACK
:
4652 /* Pass absent optional parameters. */
4660 /* Walk an intrinsic function. */
4662 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
4663 gfc_intrinsic_sym
* isym
)
4667 if (isym
->elemental
)
4668 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
4670 if (expr
->rank
== 0)
4673 if (gfc_is_intrinsic_libcall (expr
))
4674 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4676 /* Special cases. */
4679 case GFC_ISYM_LBOUND
:
4680 case GFC_ISYM_UBOUND
:
4681 return gfc_walk_intrinsic_bound (ss
, expr
);
4683 case GFC_ISYM_TRANSFER
:
4684 return gfc_walk_intrinsic_libfunc (ss
, expr
);
4687 /* This probably meant someone forgot to add an intrinsic to the above
4688 list(s) when they implemented it, or something's gone horribly
4694 #include "gt-fortran-trans-intrinsic.h"