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