]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/trans-intrinsic.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
re PR tree-optimization/14466 (missed PHI optimization (different types))
[gcc.git] / gcc / fortran / trans-intrinsic.c
CommitLineData
6de9cd9a
DN		 1/* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
9fc4d79b 6This file is part of GCC.
6de9cd9a 7
9fc4d79b
TS		 8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 2, or (at your option) any later
11version.
6de9cd9a 12
9fc4d79b
TS		 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
6de9cd9a
DN		 17
18You should have received a copy of the GNU General Public License
9fc4d79b
TS		 19along with GCC; see the file COPYING. If not, write to the Free
20Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2102111-1307, USA. */
6de9cd9a
DN		 22
23/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
24
25#include "config.h"
26#include "system.h"
27#include "coretypes.h"
28#include "tree.h"
29#include <stdio.h>
30#include <string.h>
31#include "ggc.h"
32#include "toplev.h"
33#include "real.h"
eadf906f 34#include "tree-gimple.h"
6de9cd9a
DN		 35#include "flags.h"
36#include <gmp.h>
37#include <assert.h>
38#include "gfortran.h"
39#include "intrinsic.h"
40#include "trans.h"
41#include "trans-const.h"
42#include "trans-types.h"
43#include "trans-array.h"
44#include "defaults.h"
45/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
46#include "trans-stmt.h"
47
48/* This maps fortran intrinsic math functions to external library or GCC
49 builtin functions. */
50typedef struct gfc_intrinsic_map_t GTY(())
51{
52 /* The explicit enum is required to work around inadequacies in the
53 garbage collection/gengtype parsing mechanism. */
54 enum gfc_generic_isym_id id;
55
56 /* Enum value from the "language-independent", aka C-centric, part
57 of gcc, or END_BUILTINS of no such value set. */
58 /* ??? There are now complex variants in builtins.def, though we
59 don't currently do anything with them. */
60 enum built_in_function code4;
61 enum built_in_function code8;
62
63 /* True if the naming pattern is to prepend "c" for complex and
64 append "f" for kind=4. False if the naming pattern is to
65 prepend "_gfortran_" and append "[rc][48]". */
66 bool libm_name;
67
68 /* True if a complex version of the function exists. */
69 bool complex_available;
70
71 /* True if the function should be marked const. */
72 bool is_constant;
73
74 /* The base library name of this function. */
75 const char *name;
76
77 /* Cache decls created for the various operand types. */
78 tree real4_decl;
79 tree real8_decl;
80 tree complex4_decl;
81 tree complex8_decl;
82}
83gfc_intrinsic_map_t;
84
85/* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
86 defines complex variants of all of the entries in mathbuiltins.def
87 except for atan2. */
88#define DEFINE_MATH_BUILTIN(ID, NAME, NARGS) \
89 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
90 NARGS == 1, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
91
92#define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
93 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
94 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
95
96#define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
97 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
98 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
99
100static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
101{
102 /* Functions built into gcc itself. */
103#include "mathbuiltins.def"
104
105 /* Functions in libm. */
106 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
107 pattern for other mathbuiltins.def entries. At present we have no
108 optimizations for this in the common sources. */
109 LIBM_FUNCTION (SCALE, "scalbn", false),
110
111 /* Functions in libgfortran. */
112 LIBF_FUNCTION (FRACTION, "fraction", false),
113 LIBF_FUNCTION (NEAREST, "nearest", false),
114 LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
115
116 /* End the list. */
117 LIBF_FUNCTION (NONE, NULL, false)
118};
119#undef DEFINE_MATH_BUILTIN
120#undef LIBM_FUNCTION
121#undef LIBF_FUNCTION
122
123/* Structure for storing components of a floating number to be used by
124 elemental functions to manipulate reals. */
125typedef struct
126{
127 tree arg; /* Variable tree to view convert to integer. */
128 tree expn; /* Variable tree to save exponent. */
129 tree frac; /* Variable tree to save fraction. */
130 tree smask; /* Constant tree of sign's mask. */
131 tree emask; /* Constant tree of exponent's mask. */
132 tree fmask; /* Constant tree of fraction's mask. */
133 tree edigits; /* Constant tree of bit numbers of exponent. */
134 tree fdigits; /* Constant tree of bit numbers of fraction. */
135 tree f1; /* Constant tree of the f1 defined in the real model. */
136 tree bias; /* Constant tree of the bias of exponent in the memory. */
137 tree type; /* Type tree of arg1. */
138 tree mtype; /* Type tree of integer type. Kind is that of arg1. */
139}
140real_compnt_info;
141
142
143/* Evaluate the arguments to an intrinsic function. */
144
145static tree
146gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
147{
148 gfc_actual_arglist *actual;
149 tree args;
150 gfc_se argse;
151
152 args = NULL_TREE;
153 for (actual = expr->value.function.actual; actual; actual = actual->next)
154 {
155 /* Skip ommitted optional arguments. */
156 if (!actual->expr)
157 continue;
158
159 /* Evaluate the parameter. This will substitute scalarized
160 references automatically. */
161 gfc_init_se (&argse, se);
162
163 if (actual->expr->ts.type == BT_CHARACTER)
164 {
165 gfc_conv_expr (&argse, actual->expr);
166 gfc_conv_string_parameter (&argse);
167 args = gfc_chainon_list (args, argse.string_length);
168 }
169 else
170 gfc_conv_expr_val (&argse, actual->expr);
171
172 gfc_add_block_to_block (&se->pre, &argse.pre);
173 gfc_add_block_to_block (&se->post, &argse.post);
174 args = gfc_chainon_list (args, argse.expr);
175 }
176 return args;
177}
178
179
180/* Conversions between different types are output by the frontend as
181 intrinsic functions. We implement these directly with inline code. */
182
183static void
184gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
185{
186 tree type;
187 tree arg;
188
189 /* Evaluate the argument. */
190 type = gfc_typenode_for_spec (&expr->ts);
191 assert (expr->value.function.actual->expr);
192 arg = gfc_conv_intrinsic_function_args (se, expr);
193 arg = TREE_VALUE (arg);
194
195 /* Conversion from complex to non-complex involves taking the real
196 component of the value. */
197 if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
198 && expr->ts.type != BT_COMPLEX)
199 {
200 tree artype;
201
202 artype = TREE_TYPE (TREE_TYPE (arg));
203 arg = build1 (REALPART_EXPR, artype, arg);
204 }
205
206 se->expr = convert (type, arg);
207}
208
209
210/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
211 TRUNC(x) = INT(x) <= x ? INT(x) : INT(x) - 1
212 Similarly for CEILING. */
213
214static tree
215build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
216{
217 tree tmp;
218 tree cond;
219 tree argtype;
220 tree intval;
221
222 argtype = TREE_TYPE (arg);
223 arg = gfc_evaluate_now (arg, pblock);
224
225 intval = convert (type, arg);
226 intval = gfc_evaluate_now (intval, pblock);
227
228 tmp = convert (argtype, intval);
229 cond = build (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
230
231 tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval, integer_one_node);
232 tmp = build (COND_EXPR, type, cond, intval, tmp);
233 return tmp;
234}
235
236
237/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
238 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
239
240static tree
241build_round_expr (stmtblock_t * pblock, tree arg, tree type)
242{
243 tree tmp;
244 tree cond;
245 tree neg;
246 tree pos;
247 tree argtype;
248 REAL_VALUE_TYPE r;
249
250 argtype = TREE_TYPE (arg);
251 arg = gfc_evaluate_now (arg, pblock);
252
253 real_from_string (&r, "0.5");
254 pos = build_real (argtype, r);
255
256 real_from_string (&r, "-0.5");
257 neg = build_real (argtype, r);
258
259 tmp = gfc_build_const (argtype, integer_zero_node);
260 cond = fold (build (GT_EXPR, boolean_type_node, arg, tmp));
261
262 tmp = fold (build (COND_EXPR, argtype, cond, pos, neg));
263 tmp = fold (build (PLUS_EXPR, argtype, arg, tmp));
264 return fold (build1 (FIX_TRUNC_EXPR, type, tmp));
265}
266
267
268/* Convert a real to an integer using a specific rounding mode.
269 Ideally we would just build the corresponding GENERIC node,
270 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
271
272static tree
273build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op)
274{
275 switch (op)
276 {
277 case FIX_FLOOR_EXPR:
278 return build_fixbound_expr (pblock, arg, type, 0);
279 break;
280
281 case FIX_CEIL_EXPR:
282 return build_fixbound_expr (pblock, arg, type, 1);
283 break;
284
285 case FIX_ROUND_EXPR:
286 return build_round_expr (pblock, arg, type);
287
288 default:
289 return build1 (op, type, arg);
290 }
291}
292
293
294/* Round a real value using the specified rounding mode.
295 We use a temporary integer of that same kind size as the result.
296 Values larger than can be represented by this kind are unchanged, as
297 will not be accurate enough to represent the rounding.
298 huge = HUGE (KIND (a))
299 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
300 */
301
302static void
303gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
304{
305 tree type;
306 tree itype;
307 tree arg;
308 tree tmp;
309 tree cond;
310 mpf_t huge;
311 int n;
312 int kind;
313
314 kind = expr->ts.kind;
315
316 n = END_BUILTINS;
317 /* We have builtin functions for some cases. */
318 switch (op)
319 {
320 case FIX_ROUND_EXPR:
321 switch (kind)
322 {
323 case 4:
324 n = BUILT_IN_ROUNDF;
325 break;
326
327 case 8:
328 n = BUILT_IN_ROUND;
329 break;
330 }
331 break;
332
333 case FIX_FLOOR_EXPR:
334 switch (kind)
335 {
336 case 4:
337 n = BUILT_IN_FLOORF;
338 break;
339
340 case 8:
341 n = BUILT_IN_FLOOR;
342 break;
343 }
344 }
345
346 /* Evaluate the argument. */
347 assert (expr->value.function.actual->expr);
348 arg = gfc_conv_intrinsic_function_args (se, expr);
349
350 /* Use a builtin function if one exists. */
351 if (n != END_BUILTINS)
352 {
353 tmp = built_in_decls[n];
354 se->expr = gfc_build_function_call (tmp, arg);
355 return;
356 }
357
358 /* This code is probably redundant, but we'll keep it lying around just
359 in case. */
360 type = gfc_typenode_for_spec (&expr->ts);
361 arg = TREE_VALUE (arg);
362 arg = gfc_evaluate_now (arg, &se->pre);
363
364 /* Test if the value is too large to handle sensibly. */
365 mpf_init (huge);
366 n = gfc_validate_kind (BT_INTEGER, kind);
367 mpf_set_z (huge, gfc_integer_kinds[n].huge);
368 tmp = gfc_conv_mpf_to_tree (huge, kind);
369 cond = build (LT_EXPR, boolean_type_node, arg, tmp);
370
371 mpf_neg (huge, huge);
372 tmp = gfc_conv_mpf_to_tree (huge, kind);
373 tmp = build (GT_EXPR, boolean_type_node, arg, tmp);
374 cond = build (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
375 itype = gfc_get_int_type (kind);
376
377 tmp = build_fix_expr (&se->pre, arg, itype, op);
378 tmp = convert (type, tmp);
379 se->expr = build (COND_EXPR, type, cond, tmp, arg);
380}
381
382
383/* Convert to an integer using the specified rounding mode. */
384
385static void
386gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
387{
388 tree type;
389 tree arg;
390
391 /* Evaluate the argument. */
392 type = gfc_typenode_for_spec (&expr->ts);
393 assert (expr->value.function.actual->expr);
394 arg = gfc_conv_intrinsic_function_args (se, expr);
395 arg = TREE_VALUE (arg);
396
397 if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
398 {
399 /* Conversion to a different integer kind. */
400 se->expr = convert (type, arg);
401 }
402 else
403 {
404 /* Conversion from complex to non-complex involves taking the real
405 component of the value. */
406 if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
407 && expr->ts.type != BT_COMPLEX)
408 {
409 tree artype;
410
411 artype = TREE_TYPE (TREE_TYPE (arg));
412 arg = build1 (REALPART_EXPR, artype, arg);
413 }
414
415 se->expr = build_fix_expr (&se->pre, arg, type, op);
416 }
417}
418
419
420/* Get the imaginary component of a value. */
421
422static void
423gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
424{
425 tree arg;
426
427 arg = gfc_conv_intrinsic_function_args (se, expr);
428 arg = TREE_VALUE (arg);
429 se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
430}
431
432
433/* Get the complex conjugate of a value. */
434
435static void
436gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
437{
438 tree arg;
439
440 arg = gfc_conv_intrinsic_function_args (se, expr);
441 arg = TREE_VALUE (arg);
442 se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
443}
444
445
446/* Initialize function decls for library functions. The external functions
447 are created as required. Builtin functions are added here. */
448
449void
450gfc_build_intrinsic_lib_fndecls (void)
451{
452 gfc_intrinsic_map_t *m;
453
454 /* Add GCC builtin functions. */
455 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
456 {
457 if (m->code4 != END_BUILTINS)
458 m->real4_decl = built_in_decls[m->code4];
459 if (m->code8 != END_BUILTINS)
460 m->real8_decl = built_in_decls[m->code8];
461 }
462}
463
464
465/* Create a fndecl for a simple intrinsic library function. */
466
467static tree
468gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
469{
470 tree type;
471 tree argtypes;
472 tree fndecl;
473 gfc_actual_arglist *actual;
474 tree *pdecl;
475 gfc_typespec *ts;
476 char name[GFC_MAX_SYMBOL_LEN + 3];
477
478 ts = &expr->ts;
479 if (ts->type == BT_REAL)
480 {
481 switch (ts->kind)
482 {
483 case 4:
484 pdecl = &m->real4_decl;
485 break;
486 case 8:
487 pdecl = &m->real8_decl;
488 break;
489 default:
490 abort ();
491 }
492 }
493 else if (ts->type == BT_COMPLEX)
494 {
495 if (!m->complex_available)
496 abort ();
497
498 switch (ts->kind)
499 {
500 case 4:
501 pdecl = &m->complex4_decl;
502 break;
503 case 8:
504 pdecl = &m->complex8_decl;
505 break;
506 default:
507 abort ();
508 }
509 }
510 else
511 abort ();
512
513 if (*pdecl)
514 return *pdecl;
515
516 if (m->libm_name)
517 {
518 if (ts->kind != 4 && ts->kind != 8)
519 abort ();
520 snprintf (name, sizeof (name), "%s%s%s",
521 ts->type == BT_COMPLEX ? "c" : "",
522 m->name,
523 ts->kind == 4 ? "f" : "");
524 }
525 else
526 {
527 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
528 ts->type == BT_COMPLEX ? 'c' : 'r',
529 ts->kind);
530 }
531
532 argtypes = NULL_TREE;
533 for (actual = expr->value.function.actual; actual; actual = actual->next)
534 {
535 type = gfc_typenode_for_spec (&actual->expr->ts);
536 argtypes = gfc_chainon_list (argtypes, type);
537 }
538 argtypes = gfc_chainon_list (argtypes, void_type_node);
539 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
540 fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
541
542 /* Mark the decl as external. */
543 DECL_EXTERNAL (fndecl) = 1;
544 TREE_PUBLIC (fndecl) = 1;
545
546 /* Mark it __attribute__((const)), if possible. */
547 TREE_READONLY (fndecl) = m->is_constant;
548
549 rest_of_decl_compilation (fndecl, NULL, 1, 0);
550
551 (*pdecl) = fndecl;
552 return fndecl;
553}
554
555
556/* Convert an intrinsic function into an external or builtin call. */
557
558static void
559gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
560{
561 gfc_intrinsic_map_t *m;
562 tree args;
563 tree fndecl;
564 gfc_generic_isym_id id;
565
566 id = expr->value.function.isym->generic_id;
567 /* Find the entry for this function. */
568 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
569 {
570 if (id == m->id)
571 break;
572 }
573
574 if (m->id == GFC_ISYM_NONE)
575 {
576 internal_error ("Intrinsic function %s(%d) not recognized",
577 expr->value.function.name, id);
578 }
579
580 /* Get the decl and generate the call. */
581 args = gfc_conv_intrinsic_function_args (se, expr);
582 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
583 se->expr = gfc_build_function_call (fndecl, args);
584}
585
586/* Generate code for EXPONENT(X) intrinsic function. */
587
588static void
589gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
590{
591 tree args, fndecl;
592 gfc_expr *a1;
593
594 args = gfc_conv_intrinsic_function_args (se, expr);
595
596 a1 = expr->value.function.actual->expr;
597 switch (a1->ts.kind)
598 {
599 case 4:
600 fndecl = gfor_fndecl_math_exponent4;
601 break;
602 case 8:
603 fndecl = gfor_fndecl_math_exponent8;
604 break;
605 default:
606 abort ();
607 }
608
609 se->expr = gfc_build_function_call (fndecl, args);
610}
611
612/* Evaluate a single upper or lower bound. */
613/* TODO: bound intrinsic generates way too much unneccessary code. */
614
615static void
616gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
617{
618 gfc_actual_arglist *arg;
619 gfc_actual_arglist *arg2;
620 tree desc;
621 tree type;
622 tree bound;
623 tree tmp;
624 tree cond;
625 gfc_se argse;
626 gfc_ss *ss;
627 int i;
628
629 gfc_init_se (&argse, NULL);
630 arg = expr->value.function.actual;
631 arg2 = arg->next;
632
633 if (se->ss)
634 {
635 /* Create an implicit second parameter from the loop variable. */
636 assert (!arg2->expr);
637 assert (se->loop->dimen == 1);
638 assert (se->ss->expr == expr);
639 gfc_advance_se_ss_chain (se);
640 bound = se->loop->loopvar[0];
641 bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound,
642 se->loop->from[0]));
643 }
644 else
645 {
646 /* use the passed argument. */
647 assert (arg->next->expr);
648 gfc_init_se (&argse, NULL);
649 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
650 gfc_add_block_to_block (&se->pre, &argse.pre);
651 bound = argse.expr;
652 /* Convert from one based to zero based. */
653 bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound,
654 integer_one_node));
655 }
656
657 /* TODO: don't re-evaluate the descriptor on each iteration. */
658 /* Get a descriptor for the first parameter. */
659 ss = gfc_walk_expr (arg->expr);
660 assert (ss != gfc_ss_terminator);
661 argse.want_pointer = 0;
662 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
663 gfc_add_block_to_block (&se->pre, &argse.pre);
664 gfc_add_block_to_block (&se->post, &argse.post);
665
666 desc = argse.expr;
667
668 if (INTEGER_CST_P (bound))
669 {
670 assert (TREE_INT_CST_HIGH (bound) == 0);
671 i = TREE_INT_CST_LOW (bound);
672 assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
673 }
674 else
675 {
676 if (flag_bounds_check)
677 {
678 bound = gfc_evaluate_now (bound, &se->pre);
679 cond = fold (build (LT_EXPR, boolean_type_node, bound,
680 integer_zero_node));
681 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
682 tmp = fold (build (GE_EXPR, boolean_type_node, bound, tmp));
683 cond = fold(build (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
684 gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
685 }
686 }
687
688 if (upper)
689 se->expr = gfc_conv_descriptor_ubound(desc, bound);
690 else
691 se->expr = gfc_conv_descriptor_lbound(desc, bound);
692
693 type = gfc_typenode_for_spec (&expr->ts);
694 se->expr = convert (type, se->expr);
695}
696
697
698static void
699gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
700{
701 tree args;
702 tree val;
703 tree fndecl;
704
705 args = gfc_conv_intrinsic_function_args (se, expr);
706 assert (args && TREE_CHAIN (args) == NULL_TREE);
707 val = TREE_VALUE (args);
708
709 switch (expr->value.function.actual->expr->ts.type)
710 {
711 case BT_INTEGER:
712 case BT_REAL:
713 se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
714 break;
715
716 case BT_COMPLEX:
717 switch (expr->ts.kind)
718 {
719 case 4:
720 fndecl = gfor_fndecl_math_cabsf;
721 break;
722 case 8:
723 fndecl = gfor_fndecl_math_cabs;
724 break;
725 default:
726 abort ();
727 }
728 se->expr = gfc_build_function_call (fndecl, args);
729 break;
730
731 default:
732 abort ();
733 }
734}
735
736
737/* Create a complex value from one or two real components. */
738
739static void
740gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
741{
742 tree arg;
743 tree real;
744 tree imag;
745 tree type;
746
747 type = gfc_typenode_for_spec (&expr->ts);
748 arg = gfc_conv_intrinsic_function_args (se, expr);
749 real = convert (TREE_TYPE (type), TREE_VALUE (arg));
750 if (both)
751 imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
752 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
753 {
754 arg = TREE_VALUE (arg);
755 imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
756 imag = convert (TREE_TYPE (type), imag);
757 }
758 else
759 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
760
761 se->expr = fold (build (COMPLEX_EXPR, type, real, imag));
762}
763
764/* Remainder function MOD(A, P) = A - INT(A / P) * P.
765 MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P. */
766/* TODO: MOD(x, 0) */
767
768static void
769gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
770{
771 tree arg;
772 tree arg2;
773 tree type;
774 tree itype;
775 tree tmp;
776 tree zero;
777 tree test;
778 tree test2;
779 mpf_t huge;
780 int n;
781
782 arg = gfc_conv_intrinsic_function_args (se, expr);
783 arg2 = TREE_VALUE (TREE_CHAIN (arg));
784 arg = TREE_VALUE (arg);
785 type = TREE_TYPE (arg);
786
787 switch (expr->ts.type)
788 {
789 case BT_INTEGER:
790 /* Integer case is easy, we've got a builtin op. */
791 se->expr = build (TRUNC_MOD_EXPR, type, arg, arg2);
792 break;
793
794 case BT_REAL:
795 /* Real values we have to do the hard way. */
796 arg = gfc_evaluate_now (arg, &se->pre);
797 arg2 = gfc_evaluate_now (arg2, &se->pre);
798
799 tmp = build (RDIV_EXPR, type, arg, arg2);
800 /* Test if the value is too large to handle sensibly. */
801 mpf_init (huge);
802 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind);
803 mpf_set_z (huge, gfc_integer_kinds[n].huge);
804 test = gfc_conv_mpf_to_tree (huge, expr->ts.kind);
805 test2 = build (LT_EXPR, boolean_type_node, tmp, test);
806
807 mpf_neg (huge, huge);
808 test = gfc_conv_mpf_to_tree (huge, expr->ts.kind);
809 test = build (GT_EXPR, boolean_type_node, tmp, test);
810 test2 = build (TRUTH_AND_EXPR, boolean_type_node, test, test2);
811
812 itype = gfc_get_int_type (expr->ts.kind);
813 tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
814 tmp = convert (type, tmp);
815 tmp = build (COND_EXPR, type, test2, tmp, arg);
816 tmp = build (MULT_EXPR, type, tmp, arg2);
817 se->expr = build (MINUS_EXPR, type, arg, tmp);
818 break;
819
820 default:
821 abort ();
822 }
823
824 if (modulo)
825 {
826 zero = gfc_build_const (type, integer_zero_node);
827 /* Build !(A > 0 .xor. P > 0). */
828 test = build (GT_EXPR, boolean_type_node, arg, zero);
829 test2 = build (GT_EXPR, boolean_type_node, arg2, zero);
830 test = build (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
831 test = build1 (TRUTH_NOT_EXPR, boolean_type_node, test);
832 /* Build (A == 0) .or. !(A > 0 .xor. P > 0). */
833 test2 = build (EQ_EXPR, boolean_type_node, arg, zero);
834 test = build (TRUTH_OR_EXPR, boolean_type_node, test, test2);
835
836 se->expr = build (COND_EXPR, type, test, se->expr,
837 build (PLUS_EXPR, type, se->expr, arg2));
838 }
839}
840
841/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
842
843static void
844gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
845{
846 tree arg;
847 tree arg2;
848 tree val;
849 tree tmp;
850 tree type;
851 tree zero;
852
853 arg = gfc_conv_intrinsic_function_args (se, expr);
854 arg2 = TREE_VALUE (TREE_CHAIN (arg));
855 arg = TREE_VALUE (arg);
856 type = TREE_TYPE (arg);
857
858 val = build (MINUS_EXPR, type, arg, arg2);
859 val = gfc_evaluate_now (val, &se->pre);
860
861 zero = gfc_build_const (type, integer_zero_node);
862 tmp = build (LE_EXPR, boolean_type_node, val, zero);
863 se->expr = build (COND_EXPR, type, tmp, zero, val);
864}
865
866
867/* SIGN(A, B) is absolute value of A times sign of B.
868 The real value versions use library functions to ensure the correct
869 handling of negative zero. Integer case implemented as:
870 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
871 */
872
873static void
874gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
875{
876 tree tmp;
877 tree arg;
878 tree arg2;
879 tree type;
880 tree zero;
881 tree testa;
882 tree testb;
883
884
885 arg = gfc_conv_intrinsic_function_args (se, expr);
886 if (expr->ts.type == BT_REAL)
887 {
888 switch (expr->ts.kind)
889 {
890 case 4:
891 tmp = gfor_fndecl_math_sign4;
892 break;
893 case 8:
894 tmp = gfor_fndecl_math_sign8;
895 break;
896 default:
897 abort ();
898 }
899 se->expr = gfc_build_function_call (tmp, arg);
900 return;
901 }
902
903 arg2 = TREE_VALUE (TREE_CHAIN (arg));
904 arg = TREE_VALUE (arg);
905 type = TREE_TYPE (arg);
906 zero = gfc_build_const (type, integer_zero_node);
907
908 testa = fold (build (GE_EXPR, boolean_type_node, arg, zero));
909 testb = fold (build (GE_EXPR, boolean_type_node, arg2, zero));
910 tmp = fold (build (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
911 se->expr = fold (build (COND_EXPR, type, tmp,
912 build1 (NEGATE_EXPR, type, arg), arg));
913}
914
915
916/* Test for the presence of an optional argument. */
917
918static void
919gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
920{
921 gfc_expr *arg;
922
923 arg = expr->value.function.actual->expr;
924 assert (arg->expr_type == EXPR_VARIABLE);
925 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
926 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
927}
928
929
930/* Calculate the double precision product of two single precision values. */
931
932static void
933gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
934{
935 tree arg;
936 tree arg2;
937 tree type;
938
939 arg = gfc_conv_intrinsic_function_args (se, expr);
940 arg2 = TREE_VALUE (TREE_CHAIN (arg));
941 arg = TREE_VALUE (arg);
942
943 /* Convert the args to double precision before multiplying. */
944 type = gfc_typenode_for_spec (&expr->ts);
945 arg = convert (type, arg);
946 arg2 = convert (type, arg2);
947 se->expr = build (MULT_EXPR, type, arg, arg2);
948}
949
950
951/* Return a length one character string containing an ascii character. */
952
953static void
954gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
955{
956 tree arg;
957 tree var;
958 tree type;
959
960 arg = gfc_conv_intrinsic_function_args (se, expr);
961 arg = TREE_VALUE (arg);
962
963 /* We currently don't support character types != 1. */
964 assert (expr->ts.kind == 1);
965 type = gfc_character1_type_node;
966 var = gfc_create_var (type, "char");
967
968 arg = convert (type, arg);
969 gfc_add_modify_expr (&se->pre, var, arg);
970 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
971 se->string_length = integer_one_node;
972}
973
974
975/* Get the minimum/maximum value of all the parameters.
976 minmax (a1, a2, a3, ...)
977 {
978 if (a2 .op. a1)
979 mvar = a2;
980 else
981 mvar = a1;
982 if (a3 .op. mvar)
983 mvar = a3;
984 ...
985 return mvar
986 }
987 */
988
989/* TODO: Mismatching types can occur when specific names are used.
990 These should be handled during resolution. */
991static void
992gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
993{
994 tree limit;
995 tree tmp;
996 tree mvar;
997 tree val;
998 tree thencase;
999 tree elsecase;
1000 tree arg;
1001 tree type;
1002
1003 arg = gfc_conv_intrinsic_function_args (se, expr);
1004 type = gfc_typenode_for_spec (&expr->ts);
1005
1006 limit = TREE_VALUE (arg);
1007 if (TREE_TYPE (limit) != type)
1008 limit = convert (type, limit);
1009 /* Only evaluate the argument once. */
1010 if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1011 limit = gfc_evaluate_now(limit, &se->pre);
1012
1013 mvar = gfc_create_var (type, "M");
1014 elsecase = build_v (MODIFY_EXPR, mvar, limit);
1015 for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1016 {
1017 val = TREE_VALUE (arg);
1018 if (TREE_TYPE (val) != type)
1019 val = convert (type, val);
1020
1021 /* Only evaluate the argument once. */
1022 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1023 val = gfc_evaluate_now(val, &se->pre);
1024
1025 thencase = build_v (MODIFY_EXPR, mvar, convert (type, val));
1026
1027 tmp = build (op, boolean_type_node, val, limit);
1028 tmp = build_v (COND_EXPR, tmp, thencase, elsecase);
1029 gfc_add_expr_to_block (&se->pre, tmp);
1030 elsecase = build_empty_stmt ();
1031 limit = mvar;
1032 }
1033 se->expr = mvar;
1034}
1035
1036
1037/* Create a symbol node for this intrinsic. The symbol form the frontend
1038 is for the generic name. */
1039
1040static gfc_symbol *
1041gfc_get_symbol_for_expr (gfc_expr * expr)
1042{
1043 gfc_symbol *sym;
1044
1045 /* TODO: Add symbols for intrinsic function to the global namespace. */
1046 assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1047 sym = gfc_new_symbol (expr->value.function.name, NULL);
1048
1049 sym->ts = expr->ts;
1050 sym->attr.external = 1;
1051 sym->attr.function = 1;
1052 sym->attr.always_explicit = 1;
1053 sym->attr.proc = PROC_INTRINSIC;
1054 sym->attr.flavor = FL_PROCEDURE;
1055 sym->result = sym;
1056 if (expr->rank > 0)
1057 {
1058 sym->attr.dimension = 1;
1059 sym->as = gfc_get_array_spec ();
1060 sym->as->type = AS_ASSUMED_SHAPE;
1061 sym->as->rank = expr->rank;
1062 }
1063
1064 /* TODO: proper argument lists for external intrinsics. */
1065 return sym;
1066}
1067
1068/* Generate a call to an external intrinsic function. */
1069static void
1070gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1071{
1072 gfc_symbol *sym;
1073
1074 assert (!se->ss || se->ss->expr == expr);
1075
1076 if (se->ss)
1077 assert (expr->rank > 0);
1078 else
1079 assert (expr->rank == 0);
1080
1081 sym = gfc_get_symbol_for_expr (expr);
1082 gfc_conv_function_call (se, sym, expr->value.function.actual);
1083 gfc_free (sym);
1084}
1085
1086/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1087 Implemented as
1088 any(a)
1089 {
1090 forall (i=...)
1091 if (a[i] != 0)
1092 return 1
1093 end forall
1094 return 0
1095 }
1096 all(a)
1097 {
1098 forall (i=...)
1099 if (a[i] == 0)
1100 return 0
1101 end forall
1102 return 1
1103 }
1104 */
1105static void
1106gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1107{
1108 tree resvar;
1109 stmtblock_t block;
1110 stmtblock_t body;
1111 tree type;
1112 tree tmp;
1113 tree found;
1114 gfc_loopinfo loop;
1115 gfc_actual_arglist *actual;
1116 gfc_ss *arrayss;
1117 gfc_se arrayse;
1118 tree exit_label;
1119
1120 if (se->ss)
1121 {
1122 gfc_conv_intrinsic_funcall (se, expr);
1123 return;
1124 }
1125
1126 actual = expr->value.function.actual;
1127 type = gfc_typenode_for_spec (&expr->ts);
1128 /* Initialize the result. */
1129 resvar = gfc_create_var (type, "test");
1130 if (op == EQ_EXPR)
1131 tmp = convert (type, boolean_true_node);
1132 else
1133 tmp = convert (type, boolean_false_node);
1134 gfc_add_modify_expr (&se->pre, resvar, tmp);
1135
1136 /* Walk the arguments. */
1137 arrayss = gfc_walk_expr (actual->expr);
1138 assert (arrayss != gfc_ss_terminator);
1139
1140 /* Initialize the scalarizer. */
1141 gfc_init_loopinfo (&loop);
1142 exit_label = gfc_build_label_decl (NULL_TREE);
1143 TREE_USED (exit_label) = 1;
1144 gfc_add_ss_to_loop (&loop, arrayss);
1145
1146 /* Initialize the loop. */
1147 gfc_conv_ss_startstride (&loop);
1148 gfc_conv_loop_setup (&loop);
1149
1150 gfc_mark_ss_chain_used (arrayss, 1);
1151 /* Generate the loop body. */
1152 gfc_start_scalarized_body (&loop, &body);
1153
1154 /* If the condition matches then set the return value. */
1155 gfc_start_block (&block);
1156 if (op == EQ_EXPR)
1157 tmp = convert (type, boolean_false_node);
1158 else
1159 tmp = convert (type, boolean_true_node);
1160 gfc_add_modify_expr (&block, resvar, tmp);
1161
1162 /* And break out of the loop. */
1163 tmp = build1_v (GOTO_EXPR, exit_label);
1164 gfc_add_expr_to_block (&block, tmp);
1165
1166 found = gfc_finish_block (&block);
1167
1168 /* Check this element. */
1169 gfc_init_se (&arrayse, NULL);
1170 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1171 arrayse.ss = arrayss;
1172 gfc_conv_expr_val (&arrayse, actual->expr);
1173
1174 gfc_add_block_to_block (&body, &arrayse.pre);
1175 tmp = build (op, boolean_type_node, arrayse.expr, integer_zero_node);
1176 tmp = build_v (COND_EXPR, tmp, found, build_empty_stmt ());
1177 gfc_add_expr_to_block (&body, tmp);
1178 gfc_add_block_to_block (&body, &arrayse.post);
1179
1180 gfc_trans_scalarizing_loops (&loop, &body);
1181
1182 /* Add the exit label. */
1183 tmp = build1_v (LABEL_EXPR, exit_label);
1184 gfc_add_expr_to_block (&loop.pre, tmp);
1185
1186 gfc_add_block_to_block (&se->pre, &loop.pre);
1187 gfc_add_block_to_block (&se->pre, &loop.post);
1188 gfc_cleanup_loop (&loop);
1189
1190 se->expr = resvar;
1191}
1192
1193/* COUNT(A) = Number of true elements in A. */
1194static void
1195gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1196{
1197 tree resvar;
1198 tree type;
1199 stmtblock_t body;
1200 tree tmp;
1201 gfc_loopinfo loop;
1202 gfc_actual_arglist *actual;
1203 gfc_ss *arrayss;
1204 gfc_se arrayse;
1205
1206 if (se->ss)
1207 {
1208 gfc_conv_intrinsic_funcall (se, expr);
1209 return;
1210 }
1211
1212 actual = expr->value.function.actual;
1213
1214 type = gfc_typenode_for_spec (&expr->ts);
1215 /* Initialize the result. */
1216 resvar = gfc_create_var (type, "count");
1217 gfc_add_modify_expr (&se->pre, resvar, integer_zero_node);
1218
1219 /* Walk the arguments. */
1220 arrayss = gfc_walk_expr (actual->expr);
1221 assert (arrayss != gfc_ss_terminator);
1222
1223 /* Initialize the scalarizer. */
1224 gfc_init_loopinfo (&loop);
1225 gfc_add_ss_to_loop (&loop, arrayss);
1226
1227 /* Initialize the loop. */
1228 gfc_conv_ss_startstride (&loop);
1229 gfc_conv_loop_setup (&loop);
1230
1231 gfc_mark_ss_chain_used (arrayss, 1);
1232 /* Generate the loop body. */
1233 gfc_start_scalarized_body (&loop, &body);
1234
1235 tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar, integer_one_node);
1236 tmp = build_v (MODIFY_EXPR, resvar, tmp);
1237
1238 gfc_init_se (&arrayse, NULL);
1239 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1240 arrayse.ss = arrayss;
1241 gfc_conv_expr_val (&arrayse, actual->expr);
1242 tmp = build_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1243
1244 gfc_add_block_to_block (&body, &arrayse.pre);
1245 gfc_add_expr_to_block (&body, tmp);
1246 gfc_add_block_to_block (&body, &arrayse.post);
1247
1248 gfc_trans_scalarizing_loops (&loop, &body);
1249
1250 gfc_add_block_to_block (&se->pre, &loop.pre);
1251 gfc_add_block_to_block (&se->pre, &loop.post);
1252 gfc_cleanup_loop (&loop);
1253
1254 se->expr = resvar;
1255}
1256
1257/* Inline implementation of the sum and product intrinsics. */
1258static void
1259gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1260{
1261 tree resvar;
1262 tree type;
1263 stmtblock_t body;
1264 stmtblock_t block;
1265 tree tmp;
1266 gfc_loopinfo loop;
1267 gfc_actual_arglist *actual;
1268 gfc_ss *arrayss;
1269 gfc_ss *maskss;
1270 gfc_se arrayse;
1271 gfc_se maskse;
1272 gfc_expr *arrayexpr;
1273 gfc_expr *maskexpr;
1274
1275 if (se->ss)
1276 {
1277 gfc_conv_intrinsic_funcall (se, expr);
1278 return;
1279 }
1280
1281 type = gfc_typenode_for_spec (&expr->ts);
1282 /* Initialize the result. */
1283 resvar = gfc_create_var (type, "val");
1284 if (op == PLUS_EXPR)
1285 tmp = gfc_build_const (type, integer_zero_node);
1286 else
1287 tmp = gfc_build_const (type, integer_one_node);
1288
1289 gfc_add_modify_expr (&se->pre, resvar, tmp);
1290
1291 /* Walk the arguments. */
1292 actual = expr->value.function.actual;
1293 arrayexpr = actual->expr;
1294 arrayss = gfc_walk_expr (arrayexpr);
1295 assert (arrayss != gfc_ss_terminator);
1296
1297 actual = actual->next->next;
1298 assert (actual);
1299 maskexpr = actual->expr;
1300 if (maskexpr)
1301 {
1302 maskss = gfc_walk_expr (maskexpr);
1303 assert (maskss != gfc_ss_terminator);
1304 }
1305 else
1306 maskss = NULL;
1307
1308 /* Initialize the scalarizer. */
1309 gfc_init_loopinfo (&loop);
1310 gfc_add_ss_to_loop (&loop, arrayss);
1311 if (maskss)
1312 gfc_add_ss_to_loop (&loop, maskss);
1313
1314 /* Initialize the loop. */
1315 gfc_conv_ss_startstride (&loop);
1316 gfc_conv_loop_setup (&loop);
1317
1318 gfc_mark_ss_chain_used (arrayss, 1);
1319 if (maskss)
1320 gfc_mark_ss_chain_used (maskss, 1);
1321 /* Generate the loop body. */
1322 gfc_start_scalarized_body (&loop, &body);
1323
1324 /* If we have a mask, only add this element if the mask is set. */
1325 if (maskss)
1326 {
1327 gfc_init_se (&maskse, NULL);
1328 gfc_copy_loopinfo_to_se (&maskse, &loop);
1329 maskse.ss = maskss;
1330 gfc_conv_expr_val (&maskse, maskexpr);
1331 gfc_add_block_to_block (&body, &maskse.pre);
1332
1333 gfc_start_block (&block);
1334 }
1335 else
1336 gfc_init_block (&block);
1337
1338 /* Do the actual summation/product. */
1339 gfc_init_se (&arrayse, NULL);
1340 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1341 arrayse.ss = arrayss;
1342 gfc_conv_expr_val (&arrayse, arrayexpr);
1343 gfc_add_block_to_block (&block, &arrayse.pre);
1344
1345 tmp = build (op, type, resvar, arrayse.expr);
1346 gfc_add_modify_expr (&block, resvar, tmp);
1347 gfc_add_block_to_block (&block, &arrayse.post);
1348
1349 if (maskss)
1350 {
1351 /* We enclose the above in if (mask) {...} . */
1352 tmp = gfc_finish_block (&block);
1353
1354 tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1355 }
1356 else
1357 tmp = gfc_finish_block (&block);
1358 gfc_add_expr_to_block (&body, tmp);
1359
1360 gfc_trans_scalarizing_loops (&loop, &body);
1361 gfc_add_block_to_block (&se->pre, &loop.pre);
1362 gfc_add_block_to_block (&se->pre, &loop.post);
1363 gfc_cleanup_loop (&loop);
1364
1365 se->expr = resvar;
1366}
1367
1368static void
1369gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1370{
1371 stmtblock_t body;
1372 stmtblock_t block;
1373 stmtblock_t ifblock;
1374 tree limit;
1375 tree type;
1376 tree tmp;
1377 tree ifbody;
1378 tree cond;
1379 gfc_loopinfo loop;
1380 gfc_actual_arglist *actual;
1381 gfc_ss *arrayss;
1382 gfc_ss *maskss;
1383 gfc_se arrayse;
1384 gfc_se maskse;
1385 gfc_expr *arrayexpr;
1386 gfc_expr *maskexpr;
1387 tree pos;
1388 int n;
1389
1390 if (se->ss)
1391 {
1392 gfc_conv_intrinsic_funcall (se, expr);
1393 return;
1394 }
1395
1396 /* Initialize the result. */
1397 pos = gfc_create_var (gfc_array_index_type, "pos");
1398 type = gfc_typenode_for_spec (&expr->ts);
1399
1400 /* Walk the arguments. */
1401 actual = expr->value.function.actual;
1402 arrayexpr = actual->expr;
1403 arrayss = gfc_walk_expr (arrayexpr);
1404 assert (arrayss != gfc_ss_terminator);
1405
1406 actual = actual->next->next;
1407 assert (actual);
1408 maskexpr = actual->expr;
1409 if (maskexpr)
1410 {
1411 maskss = gfc_walk_expr (maskexpr);
1412 assert (maskss != gfc_ss_terminator);
1413 }
1414 else
1415 maskss = NULL;
1416
1417 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1418 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind);
1419 switch (arrayexpr->ts.type)
1420 {
1421 case BT_REAL:
1422 tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1423 break;
1424
1425 case BT_INTEGER:
1426 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1427 arrayexpr->ts.kind);
1428 break;
1429
1430 default:
1431 abort ();
1432 }
1433
1434 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1435 if (op == GT_EXPR)
1436 tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1437 gfc_add_modify_expr (&se->pre, limit, tmp);
1438
1439 /* Initialize the scalarizer. */
1440 gfc_init_loopinfo (&loop);
1441 gfc_add_ss_to_loop (&loop, arrayss);
1442 if (maskss)
1443 gfc_add_ss_to_loop (&loop, maskss);
1444
1445 /* Initialize the loop. */
1446 gfc_conv_ss_startstride (&loop);
1447 gfc_conv_loop_setup (&loop);
1448
1449 assert (loop.dimen == 1);
1450
1451 /* Initialize the position to the first element. If the array has zero
1452 size we need to return zero. Otherwise use the first element of the
1453 array, in case all elements are equal to the limit.
1454 ie. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1455 tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
1456 loop.from[0], integer_one_node));
1457 cond = fold (build (GE_EXPR, boolean_type_node,
1458 loop.to[0], loop.from[0]));
1459 tmp = fold (build (COND_EXPR, gfc_array_index_type, cond,
1460 loop.from[0], tmp));
1461 gfc_add_modify_expr (&loop.pre, pos, tmp);
1462
1463 gfc_mark_ss_chain_used (arrayss, 1);
1464 if (maskss)
1465 gfc_mark_ss_chain_used (maskss, 1);
1466 /* Generate the loop body. */
1467 gfc_start_scalarized_body (&loop, &body);
1468
1469 /* If we have a mask, only check this element if the mask is set. */
1470 if (maskss)
1471 {
1472 gfc_init_se (&maskse, NULL);
1473 gfc_copy_loopinfo_to_se (&maskse, &loop);
1474 maskse.ss = maskss;
1475 gfc_conv_expr_val (&maskse, maskexpr);
1476 gfc_add_block_to_block (&body, &maskse.pre);
1477
1478 gfc_start_block (&block);
1479 }
1480 else
1481 gfc_init_block (&block);
1482
1483 /* Compare with the current limit. */
1484 gfc_init_se (&arrayse, NULL);
1485 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1486 arrayse.ss = arrayss;
1487 gfc_conv_expr_val (&arrayse, arrayexpr);
1488 gfc_add_block_to_block (&block, &arrayse.pre);
1489
1490 /* We do the following if this is a more extreme value. */
1491 gfc_start_block (&ifblock);
1492
1493 /* Assign the value to the limit... */
1494 gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1495
1496 /* Remember where we are. */
1497 gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1498
1499 ifbody = gfc_finish_block (&ifblock);
1500
1501 /* If it is a more extreme value. */
1502 tmp = build (op, boolean_type_node, arrayse.expr, limit);
1503 tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1504 gfc_add_expr_to_block (&block, tmp);
1505
1506 if (maskss)
1507 {
1508 /* We enclose the above in if (mask) {...}. */
1509 tmp = gfc_finish_block (&block);
1510
1511 tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1512 }
1513 else
1514 tmp = gfc_finish_block (&block);
1515 gfc_add_expr_to_block (&body, tmp);
1516
1517 gfc_trans_scalarizing_loops (&loop, &body);
1518
1519 gfc_add_block_to_block (&se->pre, &loop.pre);
1520 gfc_add_block_to_block (&se->pre, &loop.post);
1521 gfc_cleanup_loop (&loop);
1522
1523 /* Return a value in the range 1..SIZE(array). */
1524 tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1525 integer_one_node));
1526 tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp));
1527 /* And convert to the required type. */
1528 se->expr = convert (type, tmp);
1529}
1530
1531static void
1532gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1533{
1534 tree limit;
1535 tree type;
1536 tree tmp;
1537 tree ifbody;
1538 stmtblock_t body;
1539 stmtblock_t block;
1540 gfc_loopinfo loop;
1541 gfc_actual_arglist *actual;
1542 gfc_ss *arrayss;
1543 gfc_ss *maskss;
1544 gfc_se arrayse;
1545 gfc_se maskse;
1546 gfc_expr *arrayexpr;
1547 gfc_expr *maskexpr;
1548 int n;
1549
1550 if (se->ss)
1551 {
1552 gfc_conv_intrinsic_funcall (se, expr);
1553 return;
1554 }
1555
1556 type = gfc_typenode_for_spec (&expr->ts);
1557 /* Initialize the result. */
1558 limit = gfc_create_var (type, "limit");
1559 n = gfc_validate_kind (expr->ts.type, expr->ts.kind);
1560 switch (expr->ts.type)
1561 {
1562 case BT_REAL:
1563 tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1564 break;
1565
1566 case BT_INTEGER:
1567 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1568 break;
1569
1570 default:
1571 abort ();
1572 }
1573
1574 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1575 if (op == GT_EXPR)
1576 tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1577 gfc_add_modify_expr (&se->pre, limit, tmp);
1578
1579 /* Walk the arguments. */
1580 actual = expr->value.function.actual;
1581 arrayexpr = actual->expr;
1582 arrayss = gfc_walk_expr (arrayexpr);
1583 assert (arrayss != gfc_ss_terminator);
1584
1585 actual = actual->next->next;
1586 assert (actual);
1587 maskexpr = actual->expr;
1588 if (maskexpr)
1589 {
1590 maskss = gfc_walk_expr (maskexpr);
1591 assert (maskss != gfc_ss_terminator);
1592 }
1593 else
1594 maskss = NULL;
1595
1596 /* Initialize the scalarizer. */
1597 gfc_init_loopinfo (&loop);
1598 gfc_add_ss_to_loop (&loop, arrayss);
1599 if (maskss)
1600 gfc_add_ss_to_loop (&loop, maskss);
1601
1602 /* Initialize the loop. */
1603 gfc_conv_ss_startstride (&loop);
1604 gfc_conv_loop_setup (&loop);
1605
1606 gfc_mark_ss_chain_used (arrayss, 1);
1607 if (maskss)
1608 gfc_mark_ss_chain_used (maskss, 1);
1609 /* Generate the loop body. */
1610 gfc_start_scalarized_body (&loop, &body);
1611
1612 /* If we have a mask, only add this element if the mask is set. */
1613 if (maskss)
1614 {
1615 gfc_init_se (&maskse, NULL);
1616 gfc_copy_loopinfo_to_se (&maskse, &loop);
1617 maskse.ss = maskss;
1618 gfc_conv_expr_val (&maskse, maskexpr);
1619 gfc_add_block_to_block (&body, &maskse.pre);
1620
1621 gfc_start_block (&block);
1622 }
1623 else
1624 gfc_init_block (&block);
1625
1626 /* Compare with the current limit. */
1627 gfc_init_se (&arrayse, NULL);
1628 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1629 arrayse.ss = arrayss;
1630 gfc_conv_expr_val (&arrayse, arrayexpr);
1631 gfc_add_block_to_block (&block, &arrayse.pre);
1632
1633 /* Assign the value to the limit... */
1634 ifbody = build_v (MODIFY_EXPR, limit, arrayse.expr);
1635
1636 /* If it is a more extreme value. */
1637 tmp = build (op, boolean_type_node, arrayse.expr, limit);
1638 tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1639 gfc_add_expr_to_block (&block, tmp);
1640 gfc_add_block_to_block (&block, &arrayse.post);
1641
1642 tmp = gfc_finish_block (&block);
1643 if (maskss)
1644 {
1645 /* We enclose the above in if (mask) {...}. */
1646 tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1647 }
1648 gfc_add_expr_to_block (&body, tmp);
1649
1650 gfc_trans_scalarizing_loops (&loop, &body);
1651
1652 gfc_add_block_to_block (&se->pre, &loop.pre);
1653 gfc_add_block_to_block (&se->pre, &loop.post);
1654 gfc_cleanup_loop (&loop);
1655
1656 se->expr = limit;
1657}
1658
1659/* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1660static void
1661gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1662{
1663 tree arg;
1664 tree arg2;
1665 tree type;
1666 tree tmp;
1667
1668 arg = gfc_conv_intrinsic_function_args (se, expr);
1669 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1670 arg = TREE_VALUE (arg);
1671 type = TREE_TYPE (arg);
1672
1673 tmp = build (LSHIFT_EXPR, type, integer_one_node, arg2);
1674 tmp = build (BIT_AND_EXPR, type, arg, tmp);
1675 tmp = fold (build (NE_EXPR, boolean_type_node, tmp, integer_zero_node));
1676 type = gfc_typenode_for_spec (&expr->ts);
1677 se->expr = convert (type, tmp);
1678}
1679
1680/* Generate code to perform the specified operation. */
1681static void
1682gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1683{
1684 tree arg;
1685 tree arg2;
1686 tree type;
1687
1688 arg = gfc_conv_intrinsic_function_args (se, expr);
1689 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1690 arg = TREE_VALUE (arg);
1691 type = TREE_TYPE (arg);
1692
1693 se->expr = fold (build (op, type, arg, arg2));
1694}
1695
1696/* Bitwise not. */
1697static void
1698gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1699{
1700 tree arg;
1701
1702 arg = gfc_conv_intrinsic_function_args (se, expr);
1703 arg = TREE_VALUE (arg);
1704
1705 se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1706}
1707
1708/* Set or clear a single bit. */
1709static void
1710gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1711{
1712 tree arg;
1713 tree arg2;
1714 tree type;
1715 tree tmp;
1716 int op;
1717
1718 arg = gfc_conv_intrinsic_function_args (se, expr);
1719 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1720 arg = TREE_VALUE (arg);
1721 type = TREE_TYPE (arg);
1722
1723 tmp = fold (build (LSHIFT_EXPR, type, integer_one_node, arg2));
1724 if (set)
1725 op = BIT_IOR_EXPR;
1726 else
1727 {
1728 op = BIT_AND_EXPR;
1729 tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
1730 }
1731 se->expr = fold (build (op, type, arg, tmp));
1732}
1733
1734/* Extract a sequence of bits.
1735 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1736static void
1737gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1738{
1739 tree arg;
1740 tree arg2;
1741 tree arg3;
1742 tree type;
1743 tree tmp;
1744 tree mask;
1745
1746 arg = gfc_conv_intrinsic_function_args (se, expr);
1747 arg2 = TREE_CHAIN (arg);
1748 arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1749 arg = TREE_VALUE (arg);
1750 arg2 = TREE_VALUE (arg2);
1751 type = TREE_TYPE (arg);
1752
1753 mask = build_int_2 (-1, ~(unsigned HOST_WIDE_INT) 0);
1754 mask = build (LSHIFT_EXPR, type, mask, arg3);
1755 mask = build1 (BIT_NOT_EXPR, type, mask);
1756
1757 tmp = build (RSHIFT_EXPR, type, arg, arg2);
1758
1759 se->expr = fold (build (BIT_AND_EXPR, type, tmp, mask));
1760}
1761
1762/* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift. */
1763static void
1764gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1765{
1766 tree arg;
1767 tree arg2;
1768 tree type;
1769 tree tmp;
1770 tree lshift;
1771 tree rshift;
1772
1773 arg = gfc_conv_intrinsic_function_args (se, expr);
1774 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1775 arg = TREE_VALUE (arg);
1776 type = TREE_TYPE (arg);
1777
1778 /* Left shift if positive. */
1779 lshift = build (LSHIFT_EXPR, type, arg, arg2);
1780
1781 /* Right shift if negative. This will perform an arithmetic shift as
1782 we are dealing with signed integers. Section 13.5.7 allows this. */
1783 tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
1784 rshift = build (RSHIFT_EXPR, type, arg, tmp);
1785
1786 tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
1787 rshift = build (COND_EXPR, type, tmp, lshift, rshift);
1788
1789 /* Do nothing if shift == 0. */
1790 tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
1791 se->expr = build (COND_EXPR, type, tmp, arg, rshift);
1792}
1793
1794/* Circular shift. AKA rotate or barrel shift. */
1795static void
1796gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
1797{
1798 tree arg;
1799 tree arg2;
1800 tree arg3;
1801 tree type;
1802 tree tmp;
1803 tree lrot;
1804 tree rrot;
1805
1806 arg = gfc_conv_intrinsic_function_args (se, expr);
1807 arg2 = TREE_CHAIN (arg);
1808 arg3 = TREE_CHAIN (arg2);
1809 if (arg3)
1810 {
1811 /* Use a library function for the 3 parameter version. */
1812 type = TREE_TYPE (TREE_VALUE (arg));
1813 /* Convert all args to the same type otherwise we need loads of library
1814 functions. SIZE and SHIFT cannot have values > BIT_SIZE (I) so the
1815 conversion is safe. */
1816 tmp = convert (type, TREE_VALUE (arg2));
1817 TREE_VALUE (arg2) = tmp;
1818 tmp = convert (type, TREE_VALUE (arg3));
1819 TREE_VALUE (arg3) = tmp;
1820
1821 switch (expr->ts.kind)
1822 {
1823 case 4:
1824 tmp = gfor_fndecl_math_ishftc4;
1825 break;
1826 case 8:
1827 tmp = gfor_fndecl_math_ishftc8;
1828 break;
1829 default:
1830 abort ();
1831 }
1832 se->expr = gfc_build_function_call (tmp, arg);
1833 return;
1834 }
1835 arg = TREE_VALUE (arg);
1836 arg2 = TREE_VALUE (arg2);
1837 type = TREE_TYPE (arg);
1838
1839 /* Rotate left if positive. */
1840 lrot = build (LROTATE_EXPR, type, arg, arg2);
1841
1842 /* Rotate right if negative. */
1843 tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
1844 rrot = build (RROTATE_EXPR, type, arg, tmp);
1845
1846 tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
1847 rrot = build (COND_EXPR, type, tmp, lrot, rrot);
1848
1849 /* Do nothing if shift == 0. */
1850 tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
1851 se->expr = build (COND_EXPR, type, tmp, arg, rrot);
1852}
1853
1854/* The length of a character string. */
1855static void
1856gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
1857{
1858 tree len;
1859 tree type;
1860 tree decl;
1861 gfc_symbol *sym;
1862 gfc_se argse;
1863 gfc_expr *arg;
1864
1865 assert (!se->ss);
1866
1867 arg = expr->value.function.actual->expr;
1868
1869 type = gfc_typenode_for_spec (&expr->ts);
1870 switch (arg->expr_type)
1871 {
1872 case EXPR_CONSTANT:
1873 len = build_int_2 (arg->value.character.length, 0);
1874 break;
1875
1876 default:
1877 if (arg->expr_type == EXPR_VARIABLE && arg->ref == NULL)
1878 {
1879 sym = arg->symtree->n.sym;
1880 decl = gfc_get_symbol_decl (sym);
1881 if (decl == current_function_decl && sym->attr.function
1882 && (sym->result == sym))
1883 decl = gfc_get_fake_result_decl (sym);
1884
1885 len = sym->ts.cl->backend_decl;
1886 assert (len);
1887 }
1888 else
1889 {
1890 /* Anybody stupid enough to do this deserves inefficient code. */
1891 gfc_init_se (&argse, se);
1892 gfc_conv_expr (&argse, arg);
1893 gfc_add_block_to_block (&se->pre, &argse.pre);
1894 gfc_add_block_to_block (&se->post, &argse.post);
1895 len = argse.string_length;
1896 }
1897 break;
1898 }
1899 se->expr = convert (type, len);
1900}
1901
1902/* The length of a character string not including trailing blanks. */
1903static void
1904gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1905{
1906 tree args;
1907 tree type;
1908
1909 args = gfc_conv_intrinsic_function_args (se, expr);
1910 type = gfc_typenode_for_spec (&expr->ts);
1911 se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1912 se->expr = convert (type, se->expr);
1913}
1914
1915
1916/* Returns the starting position of a substring within a string. */
1917
1918static void
1919gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1920{
1921 tree args;
1922 tree back;
1923 tree type;
1924 tree tmp;
1925
1926 args = gfc_conv_intrinsic_function_args (se, expr);
1927 type = gfc_typenode_for_spec (&expr->ts);
1928 tmp = gfc_advance_chain (args, 3);
1929 if (TREE_CHAIN (tmp) == NULL_TREE)
1930 {
1931 back = convert (gfc_logical4_type_node, integer_one_node);
1932 back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
1933 TREE_CHAIN (tmp) = back;
1934 }
1935 else
1936 {
1937 back = TREE_CHAIN (tmp);
1938 TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
1939 }
1940
1941 se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1942 se->expr = convert (type, se->expr);
1943}
1944
1945/* The ascii value for a single character. */
1946static void
1947gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
1948{
1949 tree arg;
1950 tree type;
1951
1952 arg = gfc_conv_intrinsic_function_args (se, expr);
1953 arg = TREE_VALUE (TREE_CHAIN (arg));
1954 assert (POINTER_TYPE_P (TREE_TYPE (arg)));
1955 arg = build1 (NOP_EXPR, pchar_type_node, arg);
1956 type = gfc_typenode_for_spec (&expr->ts);
1957
1958 se->expr = gfc_build_indirect_ref (arg);
1959 se->expr = convert (type, se->expr);
1960}
1961
1962
1963/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
1964
1965static void
1966gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
1967{
1968 tree arg;
1969 tree tsource;
1970 tree fsource;
1971 tree mask;
1972 tree type;
1973
1974 arg = gfc_conv_intrinsic_function_args (se, expr);
1975 tsource = TREE_VALUE (arg);
1976 arg = TREE_CHAIN (arg);
1977 fsource = TREE_VALUE (arg);
1978 arg = TREE_CHAIN (arg);
1979 mask = TREE_VALUE (arg);
1980
1981 type = TREE_TYPE (tsource);
1982 se->expr = fold (build (COND_EXPR, type, mask, tsource, fsource));
1983}
1984
1985
1986static void
1987gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
1988{
1989 gfc_actual_arglist *actual;
1990 tree args;
1991 tree type;
1992 tree fndecl;
1993 gfc_se argse;
1994 gfc_ss *ss;
1995
1996 gfc_init_se (&argse, NULL);
1997 actual = expr->value.function.actual;
1998
1999 ss = gfc_walk_expr (actual->expr);
2000 assert (ss != gfc_ss_terminator);
2001 argse.want_pointer = 1;
2002 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2003 gfc_add_block_to_block (&se->pre, &argse.pre);
2004 gfc_add_block_to_block (&se->post, &argse.post);
2005 args = gfc_chainon_list (NULL_TREE, argse.expr);
2006
2007 actual = actual->next;
2008 if (actual->expr)
2009 {
2010 gfc_init_se (&argse, NULL);
2011 gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2012 gfc_add_block_to_block (&se->pre, &argse.pre);
2013 args = gfc_chainon_list (args, argse.expr);
2014 fndecl = gfor_fndecl_size1;
2015 }
2016 else
2017 fndecl = gfor_fndecl_size0;
2018
2019 se->expr = gfc_build_function_call (fndecl, args);
2020 type = gfc_typenode_for_spec (&expr->ts);
2021 se->expr = convert (type, se->expr);
2022}
2023
2024
2025/* Intrinsic string comparison functions. */
2026
2027 static void
2028gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2029{
2030 tree type;
2031 tree args;
2032
2033 args = gfc_conv_intrinsic_function_args (se, expr);
2034 /* Build a call for the comparison. */
2035 se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2036
2037 type = gfc_typenode_for_spec (&expr->ts);
2038 se->expr = build (op, type, se->expr, integer_zero_node);
2039}
2040
2041/* Generate a call to the adjustl/adjustr library function. */
2042static void
2043gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2044{
2045 tree args;
2046 tree len;
2047 tree type;
2048 tree var;
2049 tree tmp;
2050
2051 args = gfc_conv_intrinsic_function_args (se, expr);
2052 len = TREE_VALUE (args);
2053
2054 type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2055 var = gfc_conv_string_tmp (se, type, len);
2056 args = tree_cons (NULL_TREE, var, args);
2057
2058 tmp = gfc_build_function_call (fndecl, args);
2059 gfc_add_expr_to_block (&se->pre, tmp);
2060 se->expr = var;
2061 se->string_length = len;
2062}
2063
2064
2065/* Scalar transfer statement.
2066 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2067
2068static void
2069gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2070{
2071 gfc_actual_arglist *arg;
2072 gfc_se argse;
2073 tree type;
2074 tree ptr;
2075 gfc_ss *ss;
2076
2077 assert (!se->ss);
2078
2079 /* Get a pointer to the source. */
2080 arg = expr->value.function.actual;
2081 ss = gfc_walk_expr (arg->expr);
2082 gfc_init_se (&argse, NULL);
2083 if (ss == gfc_ss_terminator)
2084 gfc_conv_expr_reference (&argse, arg->expr);
2085 else
2086 gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2087 gfc_add_block_to_block (&se->pre, &argse.pre);
2088 gfc_add_block_to_block (&se->post, &argse.post);
2089 ptr = argse.expr;
2090
2091 arg = arg->next;
2092 type = gfc_typenode_for_spec (&expr->ts);
2093 ptr = convert (build_pointer_type (type), ptr);
2094 if (expr->ts.type == BT_CHARACTER)
2095 {
2096 gfc_init_se (&argse, NULL);
2097 gfc_conv_expr (&argse, arg->expr);
2098 gfc_add_block_to_block (&se->pre, &argse.pre);
2099 gfc_add_block_to_block (&se->post, &argse.post);
2100 se->expr = ptr;
2101 se->string_length = argse.string_length;
2102 }
2103 else
2104 {
2105 se->expr = gfc_build_indirect_ref (ptr);
2106 }
2107}
2108
2109
2110/* Generate code for the ALLOCATED intrinsic.
2111 Generate inline code that directly check the address of the argument. */
2112
2113static void
2114gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2115{
2116 gfc_actual_arglist *arg1;
2117 gfc_se arg1se;
2118 gfc_ss *ss1;
2119 tree tmp;
2120
2121 gfc_init_se (&arg1se, NULL);
2122 arg1 = expr->value.function.actual;
2123 ss1 = gfc_walk_expr (arg1->expr);
2124 arg1se.descriptor_only = 1;
2125 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2126
2127 tmp = gfc_conv_descriptor_data (arg1se.expr);
2128 tmp = build (NE_EXPR, boolean_type_node, tmp, null_pointer_node);
2129 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2130}
2131
2132
2133/* Generate code for the ASSOCIATED intrinsic.
2134 If both POINTER and TARGET are arrays, generate a call to library function
2135 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2136 In other cases, generate inline code that directly compare the address of
2137 POINTER with the address of TARGET. */
2138
2139static void
2140gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2141{
2142 gfc_actual_arglist *arg1;
2143 gfc_actual_arglist *arg2;
2144 gfc_se arg1se;
2145 gfc_se arg2se;
2146 tree tmp2;
2147 tree tmp;
2148 tree args, fndecl;
2149 gfc_ss *ss1, *ss2;
2150
2151 gfc_init_se (&arg1se, NULL);
2152 gfc_init_se (&arg2se, NULL);
2153 arg1 = expr->value.function.actual;
2154 arg2 = arg1->next;
2155 ss1 = gfc_walk_expr (arg1->expr);
2156
2157 if (!arg2->expr)
2158 {
2159 /* No optional target. */
2160 if (ss1 == gfc_ss_terminator)
2161 {
2162 /* A pointer to a scalar. */
2163 arg1se.want_pointer = 1;
2164 gfc_conv_expr (&arg1se, arg1->expr);
2165 tmp2 = arg1se.expr;
2166 }
2167 else
2168 {
2169 /* A pointer to an array. */
2170 arg1se.descriptor_only = 1;
2171 gfc_conv_expr_lhs (&arg1se, arg1->expr);
2172 tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2173 }
2174 tmp = build (NE_EXPR, boolean_type_node, tmp2, null_pointer_node);
2175 se->expr = tmp;
2176 }
2177 else
2178 {
2179 /* An optional target. */
2180 ss2 = gfc_walk_expr (arg2->expr);
2181 if (ss1 == gfc_ss_terminator)
2182 {
2183 /* A pointer to a scalar. */
2184 assert (ss2 == gfc_ss_terminator);
2185 arg1se.want_pointer = 1;
2186 gfc_conv_expr (&arg1se, arg1->expr);
2187 arg2se.want_pointer = 1;
2188 gfc_conv_expr (&arg2se, arg2->expr);
2189 tmp = build (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2190 se->expr = tmp;
2191 }
2192 else
2193 {
2194 /* A pointer to an array, call library function _gfor_associated. */
2195 assert (ss2 != gfc_ss_terminator);
2196 args = NULL_TREE;
2197 arg1se.want_pointer = 1;
2198 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2199 args = gfc_chainon_list (args, arg1se.expr);
2200 arg2se.want_pointer = 1;
2201 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2202 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2203 gfc_add_block_to_block (&se->post, &arg2se.post);
2204 args = gfc_chainon_list (args, arg2se.expr);
2205 fndecl = gfor_fndecl_associated;
2206 se->expr = gfc_build_function_call (fndecl, args);
2207 }
2208 }
2209 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2210}
2211
2212
2213/* Scan a string for any one of the characters in a set of characters. */
2214
2215static void
2216gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2217{
2218 tree args;
2219 tree back;
2220 tree type;
2221 tree tmp;
2222
2223 args = gfc_conv_intrinsic_function_args (se, expr);
2224 type = gfc_typenode_for_spec (&expr->ts);
2225 tmp = gfc_advance_chain (args, 3);
2226 if (TREE_CHAIN (tmp) == NULL_TREE)
2227 {
2228 back = convert (gfc_logical4_type_node, integer_one_node);
2229 back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2230 TREE_CHAIN (tmp) = back;
2231 }
2232 else
2233 {
2234 back = TREE_CHAIN (tmp);
2235 TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2236 }
2237
2238 se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2239 se->expr = convert (type, se->expr);
2240}
2241
2242
2243/* Verify that a set of characters contains all the characters in a string
2244 by indentifying the position of the first character in a string of
2245 characters that does not appear in a given set of characters. */
2246
2247static void
2248gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2249{
2250 tree args;
2251 tree back;
2252 tree type;
2253 tree tmp;
2254
2255 args = gfc_conv_intrinsic_function_args (se, expr);
2256 type = gfc_typenode_for_spec (&expr->ts);
2257 tmp = gfc_advance_chain (args, 3);
2258 if (TREE_CHAIN (tmp) == NULL_TREE)
2259 {
2260 back = convert (gfc_logical4_type_node, integer_one_node);
2261 back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2262 TREE_CHAIN (tmp) = back;
2263 }
2264 else
2265 {
2266 back = TREE_CHAIN (tmp);
2267 TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2268 }
2269
2270 se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2271 se->expr = convert (type, se->expr);
2272}
2273
2274/* Prepare components and related information of a real number which is
2275 the first argument of a elemental functions to manipulate reals. */
2276
2277static
2278void prepare_arg_info (gfc_se * se, gfc_expr * expr,
2279 real_compnt_info * rcs, int all)
2280{
2281 tree arg;
2282 tree masktype;
2283 tree tmp;
2284 tree wbits;
2285 tree one;
2286 tree exponent, fraction;
2287 int n;
2288 gfc_expr *a1;
2289
2290 if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2291 gfc_todo_error ("Non-IEEE floating format");
2292
2293 assert (expr->expr_type == EXPR_FUNCTION);
2294
2295 arg = gfc_conv_intrinsic_function_args (se, expr);
2296 arg = TREE_VALUE (arg);
2297 rcs->type = TREE_TYPE (arg);
2298
2299 /* Force arg'type to integer by unaffected convert */
2300 a1 = expr->value.function.actual->expr;
2301 masktype = gfc_get_int_type (a1->ts.kind);
2302 rcs->mtype = masktype;
2303 tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2304 arg = gfc_create_var (masktype, "arg");
2305 gfc_add_modify_expr(&se->pre, arg, tmp);
2306 rcs->arg = arg;
2307
2308 /* Caculate the numbers of bits of exponent, fraction and word */
2309 n = gfc_validate_kind (a1->ts.type, a1->ts.kind);
2310 tmp = build_int_2 (gfc_real_kinds[n].digits - 1, 0);
2311 rcs->fdigits = convert (masktype, tmp);
2312 wbits = build_int_2 (TYPE_PRECISION (rcs->type) - 1, 0);
2313 wbits = convert (masktype, wbits);
2314 rcs->edigits = fold (build (MINUS_EXPR, masktype, wbits, tmp));
2315
2316 /* Form masks for exponent/fraction/sign */
2317 one = gfc_build_const (masktype, integer_one_node);
2318 rcs->smask = fold (build (LSHIFT_EXPR, masktype, one, wbits));
2319 rcs->f1 = fold (build (LSHIFT_EXPR, masktype, one, rcs->fdigits));
2320 rcs->emask = fold (build (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
2321 rcs->fmask = fold (build (MINUS_EXPR, masktype, rcs->f1, one));
2322 /* Form bias. */
2323 tmp = fold (build (MINUS_EXPR, masktype, rcs->edigits, one));
2324 tmp = fold (build (LSHIFT_EXPR, masktype, one, tmp));
2325 rcs->bias = fold (build (MINUS_EXPR, masktype, tmp ,one));
2326
2327 if (all)
2328 {
2329 /* exponent, and fraction */
2330 tmp = build (BIT_AND_EXPR, masktype, arg, rcs->emask);
2331 tmp = build (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2332 exponent = gfc_create_var (masktype, "exponent");
2333 gfc_add_modify_expr(&se->pre, exponent, tmp);
2334 rcs->expn = exponent;
2335
2336 tmp = build (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2337 fraction = gfc_create_var (masktype, "fraction");
2338 gfc_add_modify_expr(&se->pre, fraction, tmp);
2339 rcs->frac = fraction;
2340 }
2341}
2342
2343/* Build a call to __builtin_clz. */
2344
2345static tree
2346call_builtin_clz (tree result_type, tree op0)
2347{
2348 tree fn, parms, call;
2349 enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2350
2351 if (op0_mode == TYPE_MODE (integer_type_node))
2352 fn = built_in_decls[BUILT_IN_CLZ];
2353 else if (op0_mode == TYPE_MODE (long_integer_type_node))
2354 fn = built_in_decls[BUILT_IN_CLZL];
2355 else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2356 fn = built_in_decls[BUILT_IN_CLZLL];
2357 else
2358 abort ();
2359
2360 parms = tree_cons (NULL, op0, NULL);
2361 call = gfc_build_function_call (fn, parms);
2362
2363 return convert (result_type, call);
2364}
2365
2366/* Generate code for SPACING (X) intrinsic function. We generate:
2367
2368 t = expn - (BITS_OF_FRACTION)
2369 res = t << (BITS_OF_FRACTION)
2370 if (t < 0)
2371 res = tiny(X)
2372*/
2373
2374static void
2375gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2376{
2377 tree arg;
2378 tree masktype;
2379 tree tmp, t1, cond;
2380 tree tiny, zero;
2381 tree fdigits;
2382 real_compnt_info rcs;
2383
2384 prepare_arg_info (se, expr, &rcs, 0);
2385 arg = rcs.arg;
2386 masktype = rcs.mtype;
2387 fdigits = rcs.fdigits;
2388 tiny = rcs.f1;
2389 zero = gfc_build_const (masktype, integer_zero_node);
2390 tmp = build (BIT_AND_EXPR, masktype, rcs.emask, arg);
2391 tmp = build (RSHIFT_EXPR, masktype, tmp, fdigits);
2392 tmp = build (MINUS_EXPR, masktype, tmp, fdigits);
2393 cond = build (LE_EXPR, boolean_type_node, tmp, zero);
2394 t1 = build (LSHIFT_EXPR, masktype, tmp, fdigits);
2395 tmp = build (COND_EXPR, masktype, cond, tiny, t1);
2396 tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2397
2398 se->expr = tmp;
2399}
2400
2401/* Generate code for RRSPACING (X) intrinsic function. We generate:
2402 sedigits = edigits + 1;
2403 if (expn == 0)
2404 {
2405 t1 = leadzero (frac);
2406 frac = frac << (t1 + sedigits);
2407 frac = frac >> (sedigits);
2408 }
2409 t = bias + BITS_OF_FRACTION_OF;
2410 res = (t << BITS_OF_FRACTION_OF) | frac;
2411*/
2412
2413static void
2414gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2415{
2416 tree masktype;
2417 tree tmp, t1, t2, cond;
2418 tree one, zero;
2419 tree fdigits, fraction;
2420 real_compnt_info rcs;
2421
2422 prepare_arg_info (se, expr, &rcs, 1);
2423 masktype = rcs.mtype;
2424 fdigits = rcs.fdigits;
2425 fraction = rcs.frac;
2426 one = gfc_build_const (masktype, integer_one_node);
2427 zero = gfc_build_const (masktype, integer_zero_node);
2428 t2 = build (PLUS_EXPR, masktype, rcs.edigits, one);
2429
2430 t1 = call_builtin_clz (masktype, fraction);
2431 tmp = build (PLUS_EXPR, masktype, t1, one);
2432 tmp = build (LSHIFT_EXPR, masktype, fraction, tmp);
2433 tmp = build (RSHIFT_EXPR, masktype, tmp, t2);
2434 cond = build (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2435 fraction = build (COND_EXPR, masktype, cond, tmp, fraction);
2436
2437 tmp = build (PLUS_EXPR, masktype, rcs.bias, fdigits);
2438 tmp = build (LSHIFT_EXPR, masktype, tmp, fdigits);
2439 tmp = build (BIT_IOR_EXPR, masktype, tmp, fraction);
2440
2441 tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2442 se->expr = tmp;
2443}
2444
2445/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2446
2447static void
2448gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2449{
2450 tree args;
2451
2452 args = gfc_conv_intrinsic_function_args (se, expr);
2453 args = TREE_VALUE (args);
2454 args = gfc_build_addr_expr (NULL, args);
2455 args = tree_cons (NULL_TREE, args, NULL_TREE);
2456 se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2457}
2458
2459/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2460
2461static void
2462gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2463{
2464 gfc_actual_arglist *actual;
2465 tree args;
2466 gfc_se argse;
2467
2468 args = NULL_TREE;
2469 for (actual = expr->value.function.actual; actual; actual = actual->next)
2470 {
2471 gfc_init_se (&argse, se);
2472
2473 /* Pass a NULL pointer for an absent arg. */
2474 if (actual->expr == NULL)
2475 argse.expr = null_pointer_node;
2476 else
2477 gfc_conv_expr_reference (&argse, actual->expr);
2478
2479 gfc_add_block_to_block (&se->pre, &argse.pre);
2480 gfc_add_block_to_block (&se->post, &argse.post);
2481 args = gfc_chainon_list (args, argse.expr);
2482 }
2483 se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2484}
2485
2486
2487/* Generate code for TRIM (A) intrinsic function. */
2488
2489static void
2490gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2491{
2492 tree var;
2493 tree len;
2494 tree addr;
2495 tree tmp;
2496 tree arglist;
2497 tree type;
2498 tree cond;
2499
2500 arglist = NULL_TREE;
2501
2502 type = build_pointer_type (gfc_character1_type_node);
2503 var = gfc_create_var (type, "pstr");
2504 addr = gfc_build_addr_expr (ppvoid_type_node, var);
2505 len = gfc_create_var (gfc_int4_type_node, "len");
2506
2507 tmp = gfc_conv_intrinsic_function_args (se, expr);
2508 arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2509 arglist = gfc_chainon_list (arglist, addr);
2510 arglist = chainon (arglist, tmp);
2511
2512 tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2513 gfc_add_expr_to_block (&se->pre, tmp);
2514
2515 /* Free the temporary afterwards, if necessary. */
2516 cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node);
2517 arglist = gfc_chainon_list (NULL_TREE, var);
2518 tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2519 tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2520 gfc_add_expr_to_block (&se->post, tmp);
2521
2522 se->expr = var;
2523 se->string_length = len;
2524}
2525
2526
2527/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2528
2529static void
2530gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2531{
2532 tree tmp;
2533 tree len;
2534 tree args;
2535 tree arglist;
2536 tree ncopies;
2537 tree var;
2538 tree type;
2539
2540 args = gfc_conv_intrinsic_function_args (se, expr);
2541 len = TREE_VALUE (args);
2542 tmp = gfc_advance_chain (args, 2);
2543 ncopies = TREE_VALUE (tmp);
2544 len = fold (build (MULT_EXPR, gfc_int4_type_node, len, ncopies));
2545 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2546 var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2547
2548 arglist = NULL_TREE;
2549 arglist = gfc_chainon_list (arglist, var);
2550 arglist = chainon (arglist, args);
2551 tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2552 gfc_add_expr_to_block (&se->pre, tmp);
2553
2554 se->expr = var;
2555 se->string_length = len;
2556}
2557
2558
2559/* Generate code for an intrinsic function. Some map directly to library
2560 calls, others get special handling. In some cases the name of the function
2561 used depends on the type specifiers. */
2562
2563void
2564gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2565{
2566 gfc_intrinsic_sym *isym;
2567 char *name;
2568 int lib;
2569
2570 isym = expr->value.function.isym;
2571
2572 name = &expr->value.function.name[2];
2573
2574 if (expr->rank > 0)
2575 {
2576 lib = gfc_is_intrinsic_libcall (expr);
2577 if (lib != 0)
2578 {
2579 if (lib == 1)
2580 se->ignore_optional = 1;
2581 gfc_conv_intrinsic_funcall (se, expr);
2582 return;
2583 }
2584 }
2585
2586 switch (expr->value.function.isym->generic_id)
2587 {
2588 case GFC_ISYM_NONE:
2589 abort ();
2590
2591 case GFC_ISYM_REPEAT:
2592 gfc_conv_intrinsic_repeat (se, expr);
2593 break;
2594
2595 case GFC_ISYM_TRIM:
2596 gfc_conv_intrinsic_trim (se, expr);
2597 break;
2598
2599 case GFC_ISYM_SI_KIND:
2600 gfc_conv_intrinsic_si_kind (se, expr);
2601 break;
2602
2603 case GFC_ISYM_SR_KIND:
2604 gfc_conv_intrinsic_sr_kind (se, expr);
2605 break;
2606
2607 case GFC_ISYM_EXPONENT:
2608 gfc_conv_intrinsic_exponent (se, expr);
2609 break;
2610
2611 case GFC_ISYM_SPACING:
2612 gfc_conv_intrinsic_spacing (se, expr);
2613 break;
2614
2615 case GFC_ISYM_RRSPACING:
2616 gfc_conv_intrinsic_rrspacing (se, expr);
2617 break;
2618
2619 case GFC_ISYM_SCAN:
2620 gfc_conv_intrinsic_scan (se, expr);
2621 break;
2622
2623 case GFC_ISYM_VERIFY:
2624 gfc_conv_intrinsic_verify (se, expr);
2625 break;
2626
2627 case GFC_ISYM_ALLOCATED:
2628 gfc_conv_allocated (se, expr);
2629 break;
2630
2631 case GFC_ISYM_ASSOCIATED:
2632 gfc_conv_associated(se, expr);
2633 break;
2634
2635 case GFC_ISYM_ABS:
2636 gfc_conv_intrinsic_abs (se, expr);
2637 break;
2638
2639 case GFC_ISYM_ADJUSTL:
2640 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2641 break;
2642
2643 case GFC_ISYM_ADJUSTR:
2644 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2645 break;
2646
2647 case GFC_ISYM_AIMAG:
2648 gfc_conv_intrinsic_imagpart (se, expr);
2649 break;
2650
2651 case GFC_ISYM_AINT:
2652 gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2653 break;
2654
2655 case GFC_ISYM_ALL:
2656 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2657 break;
2658
2659 case GFC_ISYM_ANINT:
2660 gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2661 break;
2662
2663 case GFC_ISYM_ANY:
2664 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2665 break;
2666
2667 case GFC_ISYM_BTEST:
2668 gfc_conv_intrinsic_btest (se, expr);
2669 break;
2670
2671 case GFC_ISYM_ACHAR:
2672 case GFC_ISYM_CHAR:
2673 gfc_conv_intrinsic_char (se, expr);
2674 break;
2675
2676 case GFC_ISYM_CONVERSION:
2677 case GFC_ISYM_REAL:
2678 case GFC_ISYM_LOGICAL:
2679 case GFC_ISYM_DBLE:
2680 gfc_conv_intrinsic_conversion (se, expr);
2681 break;
2682
2683 /* Integer conversions are handled seperately to make sure we get the
2684 correct rounding mode. */
2685 case GFC_ISYM_INT:
2686 gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2687 break;
2688
2689 case GFC_ISYM_NINT:
2690 gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2691 break;
2692
2693 case GFC_ISYM_CEILING:
2694 gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2695 break;
2696
2697 case GFC_ISYM_FLOOR:
2698 gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2699 break;
2700
2701 case GFC_ISYM_MOD:
2702 gfc_conv_intrinsic_mod (se, expr, 0);
2703 break;
2704
2705 case GFC_ISYM_MODULO:
2706 gfc_conv_intrinsic_mod (se, expr, 1);
2707 break;
2708
2709 case GFC_ISYM_CMPLX:
2710 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2711 break;
2712
2713 case GFC_ISYM_CONJG:
2714 gfc_conv_intrinsic_conjg (se, expr);
2715 break;
2716
2717 case GFC_ISYM_COUNT:
2718 gfc_conv_intrinsic_count (se, expr);
2719 break;
2720
2721 case GFC_ISYM_DIM:
2722 gfc_conv_intrinsic_dim (se, expr);
2723 break;
2724
2725 case GFC_ISYM_DPROD:
2726 gfc_conv_intrinsic_dprod (se, expr);
2727 break;
2728
2729 case GFC_ISYM_IAND:
2730 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2731 break;
2732
2733 case GFC_ISYM_IBCLR:
2734 gfc_conv_intrinsic_singlebitop (se, expr, 0);
2735 break;
2736
2737 case GFC_ISYM_IBITS:
2738 gfc_conv_intrinsic_ibits (se, expr);
2739 break;
2740
2741 case GFC_ISYM_IBSET:
2742 gfc_conv_intrinsic_singlebitop (se, expr, 1);
2743 break;
2744
2745 case GFC_ISYM_IACHAR:
2746 case GFC_ISYM_ICHAR:
2747 /* We assume ASCII character sequence. */
2748 gfc_conv_intrinsic_ichar (se, expr);
2749 break;
2750
2751 case GFC_ISYM_IEOR:
2752 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2753 break;
2754
2755 case GFC_ISYM_INDEX:
2756 gfc_conv_intrinsic_index (se, expr);
2757 break;
2758
2759 case GFC_ISYM_IOR:
2760 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2761 break;
2762
2763 case GFC_ISYM_ISHFT:
2764 gfc_conv_intrinsic_ishft (se, expr);
2765 break;
2766
2767 case GFC_ISYM_ISHFTC:
2768 gfc_conv_intrinsic_ishftc (se, expr);
2769 break;
2770
2771 case GFC_ISYM_LBOUND:
2772 gfc_conv_intrinsic_bound (se, expr, 0);
2773 break;
2774
2775 case GFC_ISYM_LEN:
2776 gfc_conv_intrinsic_len (se, expr);
2777 break;
2778
2779 case GFC_ISYM_LEN_TRIM:
2780 gfc_conv_intrinsic_len_trim (se, expr);
2781 break;
2782
2783 case GFC_ISYM_LGE:
2784 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2785 break;
2786
2787 case GFC_ISYM_LGT:
2788 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2789 break;
2790
2791 case GFC_ISYM_LLE:
2792 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2793 break;
2794
2795 case GFC_ISYM_LLT:
2796 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2797 break;
2798
2799 case GFC_ISYM_MAX:
2800 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2801 break;
2802
2803 case GFC_ISYM_MAXLOC:
2804 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2805 break;
2806
2807 case GFC_ISYM_MAXVAL:
2808 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2809 break;
2810
2811 case GFC_ISYM_MERGE:
2812 gfc_conv_intrinsic_merge (se, expr);
2813 break;
2814
2815 case GFC_ISYM_MIN:
2816 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2817 break;
2818
2819 case GFC_ISYM_MINLOC:
2820 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2821 break;
2822
2823 case GFC_ISYM_MINVAL:
2824 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2825 break;
2826
2827 case GFC_ISYM_NOT:
2828 gfc_conv_intrinsic_not (se, expr);
2829 break;
2830
2831 case GFC_ISYM_PRESENT:
2832 gfc_conv_intrinsic_present (se, expr);
2833 break;
2834
2835 case GFC_ISYM_PRODUCT:
2836 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2837 break;
2838
2839 case GFC_ISYM_SIGN:
2840 gfc_conv_intrinsic_sign (se, expr);
2841 break;
2842
2843 case GFC_ISYM_SIZE:
2844 gfc_conv_intrinsic_size (se, expr);
2845 break;
2846
2847 case GFC_ISYM_SUM:
2848 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2849 break;
2850
2851 case GFC_ISYM_TRANSFER:
2852 gfc_conv_intrinsic_transfer (se, expr);
2853 break;
2854
2855 case GFC_ISYM_UBOUND:
2856 gfc_conv_intrinsic_bound (se, expr, 1);
2857 break;
2858
2859 case GFC_ISYM_DOT_PRODUCT:
2860 case GFC_ISYM_MATMUL:
2861 gfc_conv_intrinsic_funcall (se, expr);
2862 break;
2863
2864 default:
2865 gfc_conv_intrinsic_lib_function (se, expr);
2866 break;
2867 }
2868}
2869
2870
2871/* This generates code to execute before entering the scalarization loop.
2872 Currently does nothing. */
2873
2874void
2875gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
2876{
2877 switch (ss->expr->value.function.isym->generic_id)
2878 {
2879 case GFC_ISYM_UBOUND:
2880 case GFC_ISYM_LBOUND:
2881 break;
2882
2883 default:
2884 abort ();
2885 break;
2886 }
2887}
2888
2889
2890/* UBOUND and LBOUND intrinsics with one parameter are expanded into code
2891 inside the scalarization loop. */
2892
2893static gfc_ss *
2894gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
2895{
2896 gfc_ss *newss;
2897
2898 /* The two argument version returns a scalar. */
2899 if (expr->value.function.actual->next->expr)
2900 return ss;
2901
2902 newss = gfc_get_ss ();
2903 newss->type = GFC_SS_INTRINSIC;
2904 newss->expr = expr;
2905 newss->next = ss;
2906
2907 return newss;
2908}
2909
2910
2911/* Walk an intrinsic array libcall. */
2912
2913static gfc_ss *
2914gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
2915{
2916 gfc_ss *newss;
2917
2918 assert (expr->rank > 0);
2919
2920 newss = gfc_get_ss ();
2921 newss->type = GFC_SS_FUNCTION;
2922 newss->expr = expr;
2923 newss->next = ss;
2924 newss->data.info.dimen = expr->rank;
2925
2926 return newss;
2927}
2928
2929
2930/* Returns nonzero if the specified intrinsic function call maps directly to a
2931 an external library call. Should only be used for functions that return
2932 arrays. */
2933
2934int
2935gfc_is_intrinsic_libcall (gfc_expr * expr)
2936{
2937 assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
2938 assert (expr->rank > 0);
2939
2940 switch (expr->value.function.isym->generic_id)
2941 {
2942 case GFC_ISYM_ALL:
2943 case GFC_ISYM_ANY:
2944 case GFC_ISYM_COUNT:
2945 case GFC_ISYM_MATMUL:
2946 case GFC_ISYM_MAXLOC:
2947 case GFC_ISYM_MAXVAL:
2948 case GFC_ISYM_MINLOC:
2949 case GFC_ISYM_MINVAL:
2950 case GFC_ISYM_PRODUCT:
2951 case GFC_ISYM_SUM:
2952 case GFC_ISYM_SHAPE:
2953 case GFC_ISYM_SPREAD:
2954 case GFC_ISYM_TRANSPOSE:
2955 /* Ignore absent optional parameters. */
2956 return 1;
2957
2958 case GFC_ISYM_RESHAPE:
2959 case GFC_ISYM_CSHIFT:
2960 case GFC_ISYM_EOSHIFT:
2961 case GFC_ISYM_PACK:
2962 case GFC_ISYM_UNPACK:
2963 /* Pass absent optional parameters. */
2964 return 2;
2965
2966 default:
2967 return 0;
2968 }
2969}
2970
2971/* Walk an intrinsic function. */
2972gfc_ss *
2973gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
2974 gfc_intrinsic_sym * isym)
2975{
2976 assert (isym);
2977
2978 if (isym->elemental)
2979 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
2980
2981 if (expr->rank == 0)
2982 return ss;
2983
2984 if (gfc_is_intrinsic_libcall (expr))
2985 return gfc_walk_intrinsic_libfunc (ss, expr);
2986
2987 /* Special cases. */
2988 switch (isym->generic_id)
2989 {
2990 case GFC_ISYM_LBOUND:
2991 case GFC_ISYM_UBOUND:
2992 return gfc_walk_intrinsic_bound (ss, expr);
2993
2994 default:
2995 /* This probably meant someone forgot to add an intrinsic to the above
2996 list(s) when they implemented it, or something's gone horribly wrong.
2997 */
2998 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
2999 expr->value.function.name);
3000 }
3001}
3002
3003#include "gt-fortran-trans-intrinsic.h"
GNU Compiler Collection
This page took 0.306438 seconds and 5 git commands to generate.