OSDN Git Service

* trans-expr.c: Do not include convert.h, ggc.h, real.h, and gimple.h.
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-intrinsic.c
1 /* Intrinsic translation
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3    Free Software Foundation, Inc.
4    Contributed by Paul Brook <paul@nowt.org>
5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3.  If not see
21 <http://www.gnu.org/licenses/>.  */
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 "tm.h"         /* For UNITS_PER_WORD.  */
29 #include "tree.h"
30 #include "ggc.h"
31 #include "toplev.h"
32 #include "real.h"
33 #include "flags.h"
34 #include "gfortran.h"
35 #include "arith.h"
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.  */
47 typedef struct GTY(()) gfc_intrinsic_map_t {
48   /* The explicit enum is required to work around inadequacies in the
49      garbage collection/gengtype parsing mechanism.  */
50   enum gfc_isym_id id;
51
52   /* Enum value from the "language-independent", aka C-centric, part
53      of gcc, or END_BUILTINS of no such value set.  */
54   enum built_in_function code_r4;
55   enum built_in_function code_r8;
56   enum built_in_function code_r10;
57   enum built_in_function code_r16;
58   enum built_in_function code_c4;
59   enum built_in_function code_c8;
60   enum built_in_function code_c10;
61   enum built_in_function code_c16;
62
63   /* True if the naming pattern is to prepend "c" for complex and
64      append "f" for kind=4.  False if the naming pattern is to
65      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
66   bool libm_name;
67
68   /* True if a complex version of the function exists.  */
69   bool complex_available;
70
71   /* True if the function should be marked const.  */
72   bool is_constant;
73
74   /* The base library name of this function.  */
75   const char *name;
76
77   /* Cache decls created for the various operand types.  */
78   tree real4_decl;
79   tree real8_decl;
80   tree real10_decl;
81   tree real16_decl;
82   tree complex4_decl;
83   tree complex8_decl;
84   tree complex10_decl;
85   tree complex16_decl;
86 }
87 gfc_intrinsic_map_t;
88
89 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
90    defines complex variants of all of the entries in mathbuiltins.def
91    except for atan2.  */
92 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
93   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
94     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, (enum built_in_function) 0, \
95     (enum built_in_function) 0, (enum built_in_function) 0, \
96     (enum built_in_function) 0, true, false, true, NAME, NULL_TREE, \
97     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98     NULL_TREE},
99
100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
103     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
104     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
106
107 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
108   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
112
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
114 {
115   /* Functions built into gcc itself.  */
116 #include "mathbuiltins.def"
117
118   /* Functions in libgfortran.  */
119   LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
120
121   /* End the list.  */
122   LIB_FUNCTION (NONE, NULL, false)
123
124 };
125 #undef LIB_FUNCTION
126 #undef DEFINE_MATH_BUILTIN
127 #undef DEFINE_MATH_BUILTIN_C
128
129 /* Structure for storing components of a floating number to be used by
130    elemental functions to manipulate reals.  */
131 typedef struct
132 {
133   tree arg;     /* Variable tree to view convert to integer.  */
134   tree expn;    /* Variable tree to save exponent.  */
135   tree frac;    /* Variable tree to save fraction.  */
136   tree smask;   /* Constant tree of sign's mask.  */
137   tree emask;   /* Constant tree of exponent's mask.  */
138   tree fmask;   /* Constant tree of fraction's mask.  */
139   tree edigits; /* Constant tree of the number of exponent bits.  */
140   tree fdigits; /* Constant tree of the number of fraction bits.  */
141   tree f1;      /* Constant tree of the f1 defined in the real model.  */
142   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
143   tree type;    /* Type tree of arg1.  */
144   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
145 }
146 real_compnt_info;
147
148 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
149
150 /* Evaluate the arguments to an intrinsic function.  The value
151    of NARGS may be less than the actual number of arguments in EXPR
152    to allow optional "KIND" arguments that are not included in the
153    generated code to be ignored.  */
154
155 static void
156 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
157                                   tree *argarray, int nargs)
158 {
159   gfc_actual_arglist *actual;
160   gfc_expr *e;
161   gfc_intrinsic_arg  *formal;
162   gfc_se argse;
163   int curr_arg;
164
165   formal = expr->value.function.isym->formal;
166   actual = expr->value.function.actual;
167
168    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
169         actual = actual->next,
170         formal = formal ? formal->next : NULL)
171     {
172       gcc_assert (actual);
173       e = actual->expr;
174       /* Skip omitted optional arguments.  */
175       if (!e)
176         {
177           --curr_arg;
178           continue;
179         }
180
181       /* Evaluate the parameter.  This will substitute scalarized
182          references automatically.  */
183       gfc_init_se (&argse, se);
184
185       if (e->ts.type == BT_CHARACTER)
186         {
187           gfc_conv_expr (&argse, e);
188           gfc_conv_string_parameter (&argse);
189           argarray[curr_arg++] = argse.string_length;
190           gcc_assert (curr_arg < nargs);
191         }
192       else
193         gfc_conv_expr_val (&argse, e);
194
195       /* If an optional argument is itself an optional dummy argument,
196          check its presence and substitute a null if absent.  */
197       if (e->expr_type == EXPR_VARIABLE
198             && e->symtree->n.sym->attr.optional
199             && formal
200             && formal->optional)
201         gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
202
203       gfc_add_block_to_block (&se->pre, &argse.pre);
204       gfc_add_block_to_block (&se->post, &argse.post);
205       argarray[curr_arg] = argse.expr;
206     }
207 }
208
209 /* Count the number of actual arguments to the intrinsic function EXPR
210    including any "hidden" string length arguments.  */
211
212 static unsigned int
213 gfc_intrinsic_argument_list_length (gfc_expr *expr)
214 {
215   int n = 0;
216   gfc_actual_arglist *actual;
217
218   for (actual = expr->value.function.actual; actual; actual = actual->next)
219     {
220       if (!actual->expr)
221         continue;
222
223       if (actual->expr->ts.type == BT_CHARACTER)
224         n += 2;
225       else
226         n++;
227     }
228
229   return n;
230 }
231
232
233 /* Conversions between different types are output by the frontend as
234    intrinsic functions.  We implement these directly with inline code.  */
235
236 static void
237 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
238 {
239   tree type;
240   tree *args;
241   int nargs;
242
243   nargs = gfc_intrinsic_argument_list_length (expr);
244   args = (tree *) alloca (sizeof (tree) * nargs);
245
246   /* Evaluate all the arguments passed. Whilst we're only interested in the 
247      first one here, there are other parts of the front-end that assume this 
248      and will trigger an ICE if it's not the case.  */
249   type = gfc_typenode_for_spec (&expr->ts);
250   gcc_assert (expr->value.function.actual->expr);
251   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
252
253   /* Conversion between character kinds involves a call to a library
254      function.  */
255   if (expr->ts.type == BT_CHARACTER)
256     {
257       tree fndecl, var, addr, tmp;
258
259       if (expr->ts.kind == 1
260           && expr->value.function.actual->expr->ts.kind == 4)
261         fndecl = gfor_fndecl_convert_char4_to_char1;
262       else if (expr->ts.kind == 4
263                && expr->value.function.actual->expr->ts.kind == 1)
264         fndecl = gfor_fndecl_convert_char1_to_char4;
265       else
266         gcc_unreachable ();
267
268       /* Create the variable storing the converted value.  */
269       type = gfc_get_pchar_type (expr->ts.kind);
270       var = gfc_create_var (type, "str");
271       addr = gfc_build_addr_expr (build_pointer_type (type), var);
272
273       /* Call the library function that will perform the conversion.  */
274       gcc_assert (nargs >= 2);
275       tmp = build_call_expr_loc (input_location,
276                              fndecl, 3, addr, args[0], args[1]);
277       gfc_add_expr_to_block (&se->pre, tmp);
278
279       /* Free the temporary afterwards.  */
280       tmp = gfc_call_free (var);
281       gfc_add_expr_to_block (&se->post, tmp);
282
283       se->expr = var;
284       se->string_length = args[0];
285
286       return;
287     }
288
289   /* Conversion from complex to non-complex involves taking the real
290      component of the value.  */
291   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
292       && expr->ts.type != BT_COMPLEX)
293     {
294       tree artype;
295
296       artype = TREE_TYPE (TREE_TYPE (args[0]));
297       args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
298     }
299
300   se->expr = convert (type, args[0]);
301 }
302
303 /* This is needed because the gcc backend only implements
304    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
305    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
306    Similarly for CEILING.  */
307
308 static tree
309 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
310 {
311   tree tmp;
312   tree cond;
313   tree argtype;
314   tree intval;
315
316   argtype = TREE_TYPE (arg);
317   arg = gfc_evaluate_now (arg, pblock);
318
319   intval = convert (type, arg);
320   intval = gfc_evaluate_now (intval, pblock);
321
322   tmp = convert (argtype, intval);
323   cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
324
325   tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
326                      build_int_cst (type, 1));
327   tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
328   return tmp;
329 }
330
331
332 /* Round to nearest integer, away from zero.  */
333
334 static tree
335 build_round_expr (tree arg, tree restype)
336 {
337   tree argtype;
338   tree fn;
339   bool longlong;
340   int argprec, resprec;
341
342   argtype = TREE_TYPE (arg);
343   argprec = TYPE_PRECISION (argtype);
344   resprec = TYPE_PRECISION (restype);
345
346   /* Depending on the type of the result, choose the long int intrinsic
347      (lround family) or long long intrinsic (llround).  We might also
348      need to convert the result afterwards.  */
349   if (resprec <= LONG_TYPE_SIZE)
350     longlong = false;
351   else if (resprec <= LONG_LONG_TYPE_SIZE)
352     longlong = true;
353   else
354     gcc_unreachable ();
355
356   /* Now, depending on the argument type, we choose between intrinsics.  */
357   if (argprec == TYPE_PRECISION (float_type_node))
358     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
359   else if (argprec == TYPE_PRECISION (double_type_node))
360     fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
361   else if (argprec == TYPE_PRECISION (long_double_type_node))
362     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
363   else
364     gcc_unreachable ();
365
366   return fold_convert (restype, build_call_expr_loc (input_location,
367                                                  fn, 1, arg));
368 }
369
370
371 /* Convert a real to an integer using a specific rounding mode.
372    Ideally we would just build the corresponding GENERIC node,
373    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
374
375 static tree
376 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
377                enum rounding_mode op)
378 {
379   switch (op)
380     {
381     case RND_FLOOR:
382       return build_fixbound_expr (pblock, arg, type, 0);
383       break;
384
385     case RND_CEIL:
386       return build_fixbound_expr (pblock, arg, type, 1);
387       break;
388
389     case RND_ROUND:
390       return build_round_expr (arg, type);
391       break;
392
393     case RND_TRUNC:
394       return fold_build1 (FIX_TRUNC_EXPR, type, arg);
395       break;
396
397     default:
398       gcc_unreachable ();
399     }
400 }
401
402
403 /* Round a real value using the specified rounding mode.
404    We use a temporary integer of that same kind size as the result.
405    Values larger than those that can be represented by this kind are
406    unchanged, as they will not be accurate enough to represent the
407    rounding.
408     huge = HUGE (KIND (a))
409     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
410    */
411
412 static void
413 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
414 {
415   tree type;
416   tree itype;
417   tree arg[2];
418   tree tmp;
419   tree cond;
420   mpfr_t huge;
421   int n, nargs;
422   int kind;
423
424   kind = expr->ts.kind;
425   nargs =  gfc_intrinsic_argument_list_length (expr);
426
427   n = END_BUILTINS;
428   /* We have builtin functions for some cases.  */
429   switch (op)
430     {
431     case RND_ROUND:
432       switch (kind)
433         {
434         case 4:
435           n = BUILT_IN_ROUNDF;
436           break;
437
438         case 8:
439           n = BUILT_IN_ROUND;
440           break;
441
442         case 10:
443         case 16:
444           n = BUILT_IN_ROUNDL;
445           break;
446         }
447       break;
448
449     case RND_TRUNC:
450       switch (kind)
451         {
452         case 4:
453           n = BUILT_IN_TRUNCF;
454           break;
455
456         case 8:
457           n = BUILT_IN_TRUNC;
458           break;
459
460         case 10:
461         case 16:
462           n = BUILT_IN_TRUNCL;
463           break;
464         }
465       break;
466
467     default:
468       gcc_unreachable ();
469     }
470
471   /* Evaluate the argument.  */
472   gcc_assert (expr->value.function.actual->expr);
473   gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
474
475   /* Use a builtin function if one exists.  */
476   if (n != END_BUILTINS)
477     {
478       tmp = built_in_decls[n];
479       se->expr = build_call_expr_loc (input_location,
480                                   tmp, 1, arg[0]);
481       return;
482     }
483
484   /* This code is probably redundant, but we'll keep it lying around just
485      in case.  */
486   type = gfc_typenode_for_spec (&expr->ts);
487   arg[0] = gfc_evaluate_now (arg[0], &se->pre);
488
489   /* Test if the value is too large to handle sensibly.  */
490   gfc_set_model_kind (kind);
491   mpfr_init (huge);
492   n = gfc_validate_kind (BT_INTEGER, kind, false);
493   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
494   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
495   cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
496
497   mpfr_neg (huge, huge, GFC_RND_MODE);
498   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
499   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
500   cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
501   itype = gfc_get_int_type (kind);
502
503   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
504   tmp = convert (type, tmp);
505   se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
506   mpfr_clear (huge);
507 }
508
509
510 /* Convert to an integer using the specified rounding mode.  */
511
512 static void
513 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
514 {
515   tree type;
516   tree *args;
517   int nargs;
518
519   nargs = gfc_intrinsic_argument_list_length (expr);
520   args = (tree *) alloca (sizeof (tree) * nargs);
521
522   /* Evaluate the argument, we process all arguments even though we only 
523      use the first one for code generation purposes.  */
524   type = gfc_typenode_for_spec (&expr->ts);
525   gcc_assert (expr->value.function.actual->expr);
526   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
527
528   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
529     {
530       /* Conversion to a different integer kind.  */
531       se->expr = convert (type, args[0]);
532     }
533   else
534     {
535       /* Conversion from complex to non-complex involves taking the real
536          component of the value.  */
537       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
538           && expr->ts.type != BT_COMPLEX)
539         {
540           tree artype;
541
542           artype = TREE_TYPE (TREE_TYPE (args[0]));
543           args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
544         }
545
546       se->expr = build_fix_expr (&se->pre, args[0], type, op);
547     }
548 }
549
550
551 /* Get the imaginary component of a value.  */
552
553 static void
554 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
555 {
556   tree arg;
557
558   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
559   se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
560 }
561
562
563 /* Get the complex conjugate of a value.  */
564
565 static void
566 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
567 {
568   tree arg;
569
570   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
571   se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
572 }
573
574
575 /* Initialize function decls for library functions.  The external functions
576    are created as required.  Builtin functions are added here.  */
577
578 void
579 gfc_build_intrinsic_lib_fndecls (void)
580 {
581   gfc_intrinsic_map_t *m;
582
583   /* Add GCC builtin functions.  */
584   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
585     {
586       if (m->code_r4 != END_BUILTINS)
587         m->real4_decl = built_in_decls[m->code_r4];
588       if (m->code_r8 != END_BUILTINS)
589         m->real8_decl = built_in_decls[m->code_r8];
590       if (m->code_r10 != END_BUILTINS)
591         m->real10_decl = built_in_decls[m->code_r10];
592       if (m->code_r16 != END_BUILTINS)
593         m->real16_decl = built_in_decls[m->code_r16];
594       if (m->code_c4 != END_BUILTINS)
595         m->complex4_decl = built_in_decls[m->code_c4];
596       if (m->code_c8 != END_BUILTINS)
597         m->complex8_decl = built_in_decls[m->code_c8];
598       if (m->code_c10 != END_BUILTINS)
599         m->complex10_decl = built_in_decls[m->code_c10];
600       if (m->code_c16 != END_BUILTINS)
601         m->complex16_decl = built_in_decls[m->code_c16];
602     }
603 }
604
605
606 /* Create a fndecl for a simple intrinsic library function.  */
607
608 static tree
609 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
610 {
611   tree type;
612   tree argtypes;
613   tree fndecl;
614   gfc_actual_arglist *actual;
615   tree *pdecl;
616   gfc_typespec *ts;
617   char name[GFC_MAX_SYMBOL_LEN + 3];
618
619   ts = &expr->ts;
620   if (ts->type == BT_REAL)
621     {
622       switch (ts->kind)
623         {
624         case 4:
625           pdecl = &m->real4_decl;
626           break;
627         case 8:
628           pdecl = &m->real8_decl;
629           break;
630         case 10:
631           pdecl = &m->real10_decl;
632           break;
633         case 16:
634           pdecl = &m->real16_decl;
635           break;
636         default:
637           gcc_unreachable ();
638         }
639     }
640   else if (ts->type == BT_COMPLEX)
641     {
642       gcc_assert (m->complex_available);
643
644       switch (ts->kind)
645         {
646         case 4:
647           pdecl = &m->complex4_decl;
648           break;
649         case 8:
650           pdecl = &m->complex8_decl;
651           break;
652         case 10:
653           pdecl = &m->complex10_decl;
654           break;
655         case 16:
656           pdecl = &m->complex16_decl;
657           break;
658         default:
659           gcc_unreachable ();
660         }
661     }
662   else
663     gcc_unreachable ();
664
665   if (*pdecl)
666     return *pdecl;
667
668   if (m->libm_name)
669     {
670       if (ts->kind == 4)
671         snprintf (name, sizeof (name), "%s%s%s",
672                 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
673       else if (ts->kind == 8)
674         snprintf (name, sizeof (name), "%s%s",
675                 ts->type == BT_COMPLEX ? "c" : "", m->name);
676       else
677         {
678           gcc_assert (ts->kind == 10 || ts->kind == 16);
679           snprintf (name, sizeof (name), "%s%s%s",
680                 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
681         }
682     }
683   else
684     {
685       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
686                 ts->type == BT_COMPLEX ? 'c' : 'r',
687                 ts->kind);
688     }
689
690   argtypes = NULL_TREE;
691   for (actual = expr->value.function.actual; actual; actual = actual->next)
692     {
693       type = gfc_typenode_for_spec (&actual->expr->ts);
694       argtypes = gfc_chainon_list (argtypes, type);
695     }
696   argtypes = gfc_chainon_list (argtypes, void_type_node);
697   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
698   fndecl = build_decl (input_location,
699                        FUNCTION_DECL, get_identifier (name), type);
700
701   /* Mark the decl as external.  */
702   DECL_EXTERNAL (fndecl) = 1;
703   TREE_PUBLIC (fndecl) = 1;
704
705   /* Mark it __attribute__((const)), if possible.  */
706   TREE_READONLY (fndecl) = m->is_constant;
707
708   rest_of_decl_compilation (fndecl, 1, 0);
709
710   (*pdecl) = fndecl;
711   return fndecl;
712 }
713
714
715 /* Convert an intrinsic function into an external or builtin call.  */
716
717 static void
718 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
719 {
720   gfc_intrinsic_map_t *m;
721   tree fndecl;
722   tree rettype;
723   tree *args;
724   unsigned int num_args;
725   gfc_isym_id id;
726
727   id = expr->value.function.isym->id;
728   /* Find the entry for this function.  */
729   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
730     {
731       if (id == m->id)
732         break;
733     }
734
735   if (m->id == GFC_ISYM_NONE)
736     {
737       internal_error ("Intrinsic function %s(%d) not recognized",
738                       expr->value.function.name, id);
739     }
740
741   /* Get the decl and generate the call.  */
742   num_args = gfc_intrinsic_argument_list_length (expr);
743   args = (tree *) alloca (sizeof (tree) * num_args);
744
745   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
746   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
747   rettype = TREE_TYPE (TREE_TYPE (fndecl));
748
749   fndecl = build_addr (fndecl, current_function_decl);
750   se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
751 }
752
753
754 /* If bounds-checking is enabled, create code to verify at runtime that the
755    string lengths for both expressions are the same (needed for e.g. MERGE).
756    If bounds-checking is not enabled, does nothing.  */
757
758 void
759 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
760                              tree a, tree b, stmtblock_t* target)
761 {
762   tree cond;
763   tree name;
764
765   /* If bounds-checking is disabled, do nothing.  */
766   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
767     return;
768
769   /* Compare the two string lengths.  */
770   cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
771
772   /* Output the runtime-check.  */
773   name = gfc_build_cstring_const (intr_name);
774   name = gfc_build_addr_expr (pchar_type_node, name);
775   gfc_trans_runtime_check (true, false, cond, target, where,
776                            "Unequal character lengths (%ld/%ld) in %s",
777                            fold_convert (long_integer_type_node, a),
778                            fold_convert (long_integer_type_node, b), name);
779 }
780
781
782 /* The EXPONENT(s) intrinsic function is translated into
783        int ret;
784        frexp (s, &ret);
785        return ret;
786  */
787
788 static void
789 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
790 {
791   tree arg, type, res, tmp;
792   int frexp;
793
794   switch (expr->value.function.actual->expr->ts.kind)
795     {
796     case 4:
797       frexp = BUILT_IN_FREXPF;
798       break;
799     case 8:
800       frexp = BUILT_IN_FREXP;
801       break;
802     case 10:
803     case 16:
804       frexp = BUILT_IN_FREXPL;
805       break;
806     default:
807       gcc_unreachable ();
808     }
809
810   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
811
812   res = gfc_create_var (integer_type_node, NULL);
813   tmp = build_call_expr_loc (input_location,
814                          built_in_decls[frexp], 2, arg,
815                          gfc_build_addr_expr (NULL_TREE, res));
816   gfc_add_expr_to_block (&se->pre, tmp);
817
818   type = gfc_typenode_for_spec (&expr->ts);
819   se->expr = fold_convert (type, res);
820 }
821
822 /* Evaluate a single upper or lower bound.  */
823 /* TODO: bound intrinsic generates way too much unnecessary code.  */
824
825 static void
826 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
827 {
828   gfc_actual_arglist *arg;
829   gfc_actual_arglist *arg2;
830   tree desc;
831   tree type;
832   tree bound;
833   tree tmp;
834   tree cond, cond1, cond3, cond4, size;
835   tree ubound;
836   tree lbound;
837   gfc_se argse;
838   gfc_ss *ss;
839   gfc_array_spec * as;
840
841   arg = expr->value.function.actual;
842   arg2 = arg->next;
843
844   if (se->ss)
845     {
846       /* Create an implicit second parameter from the loop variable.  */
847       gcc_assert (!arg2->expr);
848       gcc_assert (se->loop->dimen == 1);
849       gcc_assert (se->ss->expr == expr);
850       gfc_advance_se_ss_chain (se);
851       bound = se->loop->loopvar[0];
852       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
853                            se->loop->from[0]);
854     }
855   else
856     {
857       /* use the passed argument.  */
858       gcc_assert (arg->next->expr);
859       gfc_init_se (&argse, NULL);
860       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
861       gfc_add_block_to_block (&se->pre, &argse.pre);
862       bound = argse.expr;
863       /* Convert from one based to zero based.  */
864       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
865                            gfc_index_one_node);
866     }
867
868   /* TODO: don't re-evaluate the descriptor on each iteration.  */
869   /* Get a descriptor for the first parameter.  */
870   ss = gfc_walk_expr (arg->expr);
871   gcc_assert (ss != gfc_ss_terminator);
872   gfc_init_se (&argse, NULL);
873   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
874   gfc_add_block_to_block (&se->pre, &argse.pre);
875   gfc_add_block_to_block (&se->post, &argse.post);
876
877   desc = argse.expr;
878
879   if (INTEGER_CST_P (bound))
880     {
881       int hi, low;
882
883       hi = TREE_INT_CST_HIGH (bound);
884       low = TREE_INT_CST_LOW (bound);
885       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
886         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
887                    "dimension index", upper ? "UBOUND" : "LBOUND",
888                    &expr->where);
889     }
890   else
891     {
892       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
893         {
894           bound = gfc_evaluate_now (bound, &se->pre);
895           cond = fold_build2 (LT_EXPR, boolean_type_node,
896                               bound, build_int_cst (TREE_TYPE (bound), 0));
897           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
898           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
899           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
900           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
901                                    gfc_msg_fault);
902         }
903     }
904
905   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
906   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
907   
908   as = gfc_get_full_arrayspec_from_expr (arg->expr);
909
910   /* 13.14.53: Result value for LBOUND
911
912      Case (i): For an array section or for an array expression other than a
913                whole array or array structure component, LBOUND(ARRAY, DIM)
914                has the value 1.  For a whole array or array structure
915                component, LBOUND(ARRAY, DIM) has the value:
916                  (a) equal to the lower bound for subscript DIM of ARRAY if
917                      dimension DIM of ARRAY does not have extent zero
918                      or if ARRAY is an assumed-size array of rank DIM,
919               or (b) 1 otherwise.
920
921      13.14.113: Result value for UBOUND
922
923      Case (i): For an array section or for an array expression other than a
924                whole array or array structure component, UBOUND(ARRAY, DIM)
925                has the value equal to the number of elements in the given
926                dimension; otherwise, it has a value equal to the upper bound
927                for subscript DIM of ARRAY if dimension DIM of ARRAY does
928                not have size zero and has value zero if dimension DIM has
929                size zero.  */
930
931   if (as)
932     {
933       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
934
935       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
936
937       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
938                            gfc_index_zero_node);
939       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
940
941       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
942                            gfc_index_zero_node);
943
944       if (upper)
945         {
946           tree cond5;
947           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
948
949           cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
950           cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
951
952           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
953
954           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
955                                   ubound, gfc_index_zero_node);
956         }
957       else
958         {
959           if (as->type == AS_ASSUMED_SIZE)
960             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
961                                 build_int_cst (TREE_TYPE (bound),
962                                                arg->expr->rank - 1));
963           else
964             cond = boolean_false_node;
965
966           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
967           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
968
969           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
970                                   lbound, gfc_index_one_node);
971         }
972     }
973   else
974     {
975       if (upper)
976         {
977           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
978           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
979                                   gfc_index_one_node);
980           se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
981                                   gfc_index_zero_node);
982         }
983       else
984         se->expr = gfc_index_one_node;
985     }
986
987   type = gfc_typenode_for_spec (&expr->ts);
988   se->expr = convert (type, se->expr);
989 }
990
991
992 static void
993 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
994 {
995   tree arg;
996   int n;
997
998   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
999
1000   switch (expr->value.function.actual->expr->ts.type)
1001     {
1002     case BT_INTEGER:
1003     case BT_REAL:
1004       se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1005       break;
1006
1007     case BT_COMPLEX:
1008       switch (expr->ts.kind)
1009         {
1010         case 4:
1011           n = BUILT_IN_CABSF;
1012           break;
1013         case 8:
1014           n = BUILT_IN_CABS;
1015           break;
1016         case 10:
1017         case 16:
1018           n = BUILT_IN_CABSL;
1019           break;
1020         default:
1021           gcc_unreachable ();
1022         }
1023       se->expr = build_call_expr_loc (input_location,
1024                                   built_in_decls[n], 1, arg);
1025       break;
1026
1027     default:
1028       gcc_unreachable ();
1029     }
1030 }
1031
1032
1033 /* Create a complex value from one or two real components.  */
1034
1035 static void
1036 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1037 {
1038   tree real;
1039   tree imag;
1040   tree type;
1041   tree *args;
1042   unsigned int num_args;
1043
1044   num_args = gfc_intrinsic_argument_list_length (expr);
1045   args = (tree *) alloca (sizeof (tree) * num_args);
1046
1047   type = gfc_typenode_for_spec (&expr->ts);
1048   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1049   real = convert (TREE_TYPE (type), args[0]);
1050   if (both)
1051     imag = convert (TREE_TYPE (type), args[1]);
1052   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1053     {
1054       imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1055                           args[0]);
1056       imag = convert (TREE_TYPE (type), imag);
1057     }
1058   else
1059     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1060
1061   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1062 }
1063
1064 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1065                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1066 /* TODO: MOD(x, 0)  */
1067
1068 static void
1069 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1070 {
1071   tree type;
1072   tree itype;
1073   tree tmp;
1074   tree test;
1075   tree test2;
1076   mpfr_t huge;
1077   int n, ikind;
1078   tree args[2];
1079
1080   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1081
1082   switch (expr->ts.type)
1083     {
1084     case BT_INTEGER:
1085       /* Integer case is easy, we've got a builtin op.  */
1086       type = TREE_TYPE (args[0]);
1087
1088       if (modulo)
1089        se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1090       else
1091        se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1092       break;
1093
1094     case BT_REAL:
1095       n = END_BUILTINS;
1096       /* Check if we have a builtin fmod.  */
1097       switch (expr->ts.kind)
1098         {
1099         case 4:
1100           n = BUILT_IN_FMODF;
1101           break;
1102
1103         case 8:
1104           n = BUILT_IN_FMOD;
1105           break;
1106
1107         case 10:
1108         case 16:
1109           n = BUILT_IN_FMODL;
1110           break;
1111
1112         default:
1113           break;
1114         }
1115
1116       /* Use it if it exists.  */
1117       if (n != END_BUILTINS)
1118         {
1119           tmp = build_addr (built_in_decls[n], current_function_decl);
1120           se->expr = build_call_array_loc (input_location,
1121                                        TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1122                                        tmp, 2, args);
1123           if (modulo == 0)
1124             return;
1125         }
1126
1127       type = TREE_TYPE (args[0]);
1128
1129       args[0] = gfc_evaluate_now (args[0], &se->pre);
1130       args[1] = gfc_evaluate_now (args[1], &se->pre);
1131
1132       /* Definition:
1133          modulo = arg - floor (arg/arg2) * arg2, so
1134                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, 
1135          where
1136           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1137          thereby avoiding another division and retaining the accuracy
1138          of the builtin function.  */
1139       if (n != END_BUILTINS && modulo)
1140         {
1141           tree zero = gfc_build_const (type, integer_zero_node);
1142           tmp = gfc_evaluate_now (se->expr, &se->pre);
1143           test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1144           test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1145           test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1146           test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1147           test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1148           test = gfc_evaluate_now (test, &se->pre);
1149           se->expr = fold_build3 (COND_EXPR, type, test,
1150                                   fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1151                                   tmp);
1152           return;
1153         }
1154
1155       /* If we do not have a built_in fmod, the calculation is going to
1156          have to be done longhand.  */
1157       tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1158
1159       /* Test if the value is too large to handle sensibly.  */
1160       gfc_set_model_kind (expr->ts.kind);
1161       mpfr_init (huge);
1162       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1163       ikind = expr->ts.kind;
1164       if (n < 0)
1165         {
1166           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1167           ikind = gfc_max_integer_kind;
1168         }
1169       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1170       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1171       test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1172
1173       mpfr_neg (huge, huge, GFC_RND_MODE);
1174       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1175       test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1176       test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1177
1178       itype = gfc_get_int_type (ikind);
1179       if (modulo)
1180        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1181       else
1182        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1183       tmp = convert (type, tmp);
1184       tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1185       tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1186       se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1187       mpfr_clear (huge);
1188       break;
1189
1190     default:
1191       gcc_unreachable ();
1192     }
1193 }
1194
1195 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1196
1197 static void
1198 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1199 {
1200   tree val;
1201   tree tmp;
1202   tree type;
1203   tree zero;
1204   tree args[2];
1205
1206   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1207   type = TREE_TYPE (args[0]);
1208
1209   val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1210   val = gfc_evaluate_now (val, &se->pre);
1211
1212   zero = gfc_build_const (type, integer_zero_node);
1213   tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1214   se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1215 }
1216
1217
1218 /* SIGN(A, B) is absolute value of A times sign of B.
1219    The real value versions use library functions to ensure the correct
1220    handling of negative zero.  Integer case implemented as:
1221    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1222   */
1223
1224 static void
1225 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1226 {
1227   tree tmp;
1228   tree type;
1229   tree args[2];
1230
1231   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1232   if (expr->ts.type == BT_REAL)
1233     {
1234       tree abs;
1235
1236       switch (expr->ts.kind)
1237         {
1238         case 4:
1239           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1240           abs = built_in_decls[BUILT_IN_FABSF];
1241           break;
1242         case 8:
1243           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1244           abs = built_in_decls[BUILT_IN_FABS];
1245           break;
1246         case 10:
1247         case 16:
1248           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1249           abs = built_in_decls[BUILT_IN_FABSL];
1250           break;
1251         default:
1252           gcc_unreachable ();
1253         }
1254
1255       /* We explicitly have to ignore the minus sign. We do so by using
1256          result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
1257       if (!gfc_option.flag_sign_zero
1258           && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1259         {
1260           tree cond, zero;
1261           zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1262           cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
1263           se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
1264                                   build_call_expr (abs, 1, args[0]),
1265                                   build_call_expr (tmp, 2, args[0], args[1]));
1266         }
1267       else
1268         se->expr = build_call_expr_loc (input_location,
1269                                   tmp, 2, args[0], args[1]);
1270       return;
1271     }
1272
1273   /* Having excluded floating point types, we know we are now dealing
1274      with signed integer types.  */
1275   type = TREE_TYPE (args[0]);
1276
1277   /* Args[0] is used multiple times below.  */
1278   args[0] = gfc_evaluate_now (args[0], &se->pre);
1279
1280   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1281      the signs of A and B are the same, and of all ones if they differ.  */
1282   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1283   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1284                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1285   tmp = gfc_evaluate_now (tmp, &se->pre);
1286
1287   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1288      is all ones (i.e. -1).  */
1289   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1290                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1291                           tmp);
1292 }
1293
1294
1295 /* Test for the presence of an optional argument.  */
1296
1297 static void
1298 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1299 {
1300   gfc_expr *arg;
1301
1302   arg = expr->value.function.actual->expr;
1303   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1304   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1305   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1306 }
1307
1308
1309 /* Calculate the double precision product of two single precision values.  */
1310
1311 static void
1312 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1313 {
1314   tree type;
1315   tree args[2];
1316
1317   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1318
1319   /* Convert the args to double precision before multiplying.  */
1320   type = gfc_typenode_for_spec (&expr->ts);
1321   args[0] = convert (type, args[0]);
1322   args[1] = convert (type, args[1]);
1323   se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1324 }
1325
1326
1327 /* Return a length one character string containing an ascii character.  */
1328
1329 static void
1330 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1331 {
1332   tree arg[2];
1333   tree var;
1334   tree type;
1335   unsigned int num_args;
1336
1337   num_args = gfc_intrinsic_argument_list_length (expr);
1338   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1339
1340   type = gfc_get_char_type (expr->ts.kind);
1341   var = gfc_create_var (type, "char");
1342
1343   arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1344   gfc_add_modify (&se->pre, var, arg[0]);
1345   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1346   se->string_length = integer_one_node;
1347 }
1348
1349
1350 static void
1351 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1352 {
1353   tree var;
1354   tree len;
1355   tree tmp;
1356   tree cond;
1357   tree fndecl;
1358   tree *args;
1359   unsigned int num_args;
1360
1361   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1362   args = (tree *) alloca (sizeof (tree) * num_args);
1363
1364   var = gfc_create_var (pchar_type_node, "pstr");
1365   len = gfc_create_var (gfc_get_int_type (8), "len");
1366
1367   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1368   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1369   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1370
1371   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1372   tmp = build_call_array_loc (input_location,
1373                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1374                           fndecl, num_args, args);
1375   gfc_add_expr_to_block (&se->pre, tmp);
1376
1377   /* Free the temporary afterwards, if necessary.  */
1378   cond = fold_build2 (GT_EXPR, boolean_type_node,
1379                       len, build_int_cst (TREE_TYPE (len), 0));
1380   tmp = gfc_call_free (var);
1381   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1382   gfc_add_expr_to_block (&se->post, tmp);
1383
1384   se->expr = var;
1385   se->string_length = len;
1386 }
1387
1388
1389 static void
1390 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1391 {
1392   tree var;
1393   tree len;
1394   tree tmp;
1395   tree cond;
1396   tree fndecl;
1397   tree *args;
1398   unsigned int num_args;
1399
1400   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1401   args = (tree *) alloca (sizeof (tree) * num_args);
1402
1403   var = gfc_create_var (pchar_type_node, "pstr");
1404   len = gfc_create_var (gfc_get_int_type (4), "len");
1405
1406   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1407   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1408   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1409
1410   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1411   tmp = build_call_array_loc (input_location,
1412                           TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1413                           fndecl, num_args, args);
1414   gfc_add_expr_to_block (&se->pre, tmp);
1415
1416   /* Free the temporary afterwards, if necessary.  */
1417   cond = fold_build2 (GT_EXPR, boolean_type_node,
1418                       len, build_int_cst (TREE_TYPE (len), 0));
1419   tmp = gfc_call_free (var);
1420   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1421   gfc_add_expr_to_block (&se->post, tmp);
1422
1423   se->expr = var;
1424   se->string_length = len;
1425 }
1426
1427
1428 /* Return a character string containing the tty name.  */
1429
1430 static void
1431 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1432 {
1433   tree var;
1434   tree len;
1435   tree tmp;
1436   tree cond;
1437   tree fndecl;
1438   tree *args;
1439   unsigned int num_args;
1440
1441   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1442   args = (tree *) alloca (sizeof (tree) * num_args);
1443
1444   var = gfc_create_var (pchar_type_node, "pstr");
1445   len = gfc_create_var (gfc_get_int_type (4), "len");
1446
1447   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1448   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1449   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1450
1451   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1452   tmp = build_call_array_loc (input_location,
1453                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1454                           fndecl, num_args, args);
1455   gfc_add_expr_to_block (&se->pre, tmp);
1456
1457   /* Free the temporary afterwards, if necessary.  */
1458   cond = fold_build2 (GT_EXPR, boolean_type_node,
1459                       len, build_int_cst (TREE_TYPE (len), 0));
1460   tmp = gfc_call_free (var);
1461   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1462   gfc_add_expr_to_block (&se->post, tmp);
1463
1464   se->expr = var;
1465   se->string_length = len;
1466 }
1467
1468
1469 /* Get the minimum/maximum value of all the parameters.
1470     minmax (a1, a2, a3, ...)
1471     {
1472       mvar = a1;
1473       if (a2 .op. mvar || isnan(mvar))
1474         mvar = a2;
1475       if (a3 .op. mvar || isnan(mvar))
1476         mvar = a3;
1477       ...
1478       return mvar
1479     }
1480  */
1481
1482 /* TODO: Mismatching types can occur when specific names are used.
1483    These should be handled during resolution.  */
1484 static void
1485 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1486 {
1487   tree tmp;
1488   tree mvar;
1489   tree val;
1490   tree thencase;
1491   tree *args;
1492   tree type;
1493   gfc_actual_arglist *argexpr;
1494   unsigned int i, nargs;
1495
1496   nargs = gfc_intrinsic_argument_list_length (expr);
1497   args = (tree *) alloca (sizeof (tree) * nargs);
1498
1499   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1500   type = gfc_typenode_for_spec (&expr->ts);
1501
1502   argexpr = expr->value.function.actual;
1503   if (TREE_TYPE (args[0]) != type)
1504     args[0] = convert (type, args[0]);
1505   /* Only evaluate the argument once.  */
1506   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1507     args[0] = gfc_evaluate_now (args[0], &se->pre);
1508
1509   mvar = gfc_create_var (type, "M");
1510   gfc_add_modify (&se->pre, mvar, args[0]);
1511   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1512     {
1513       tree cond, isnan;
1514
1515       val = args[i]; 
1516
1517       /* Handle absent optional arguments by ignoring the comparison.  */
1518       if (argexpr->expr->expr_type == EXPR_VARIABLE
1519           && argexpr->expr->symtree->n.sym->attr.optional
1520           && TREE_CODE (val) == INDIRECT_REF)
1521         cond = fold_build2_loc (input_location,
1522                                 NE_EXPR, boolean_type_node,
1523                                 TREE_OPERAND (val, 0), 
1524                         build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1525       else
1526       {
1527         cond = NULL_TREE;
1528
1529         /* Only evaluate the argument once.  */
1530         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1531           val = gfc_evaluate_now (val, &se->pre);
1532       }
1533
1534       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1535
1536       tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1537
1538       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1539          __builtin_isnan might be made dependent on that module being loaded,
1540          to help performance of programs that don't rely on IEEE semantics.  */
1541       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1542         {
1543           isnan = build_call_expr_loc (input_location,
1544                                    built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1545           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1546                              fold_convert (boolean_type_node, isnan));
1547         }
1548       tmp = build3_v (COND_EXPR, tmp, thencase,
1549                       build_empty_stmt (input_location));
1550
1551       if (cond != NULL_TREE)
1552         tmp = build3_v (COND_EXPR, cond, tmp,
1553                         build_empty_stmt (input_location));
1554
1555       gfc_add_expr_to_block (&se->pre, tmp);
1556       argexpr = argexpr->next;
1557     }
1558   se->expr = mvar;
1559 }
1560
1561
1562 /* Generate library calls for MIN and MAX intrinsics for character
1563    variables.  */
1564 static void
1565 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1566 {
1567   tree *args;
1568   tree var, len, fndecl, tmp, cond, function;
1569   unsigned int nargs;
1570
1571   nargs = gfc_intrinsic_argument_list_length (expr);
1572   args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1573   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1574
1575   /* Create the result variables.  */
1576   len = gfc_create_var (gfc_charlen_type_node, "len");
1577   args[0] = gfc_build_addr_expr (NULL_TREE, len);
1578   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1579   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1580   args[2] = build_int_cst (NULL_TREE, op);
1581   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1582
1583   if (expr->ts.kind == 1)
1584     function = gfor_fndecl_string_minmax;
1585   else if (expr->ts.kind == 4)
1586     function = gfor_fndecl_string_minmax_char4;
1587   else
1588     gcc_unreachable ();
1589
1590   /* Make the function call.  */
1591   fndecl = build_addr (function, current_function_decl);
1592   tmp = build_call_array_loc (input_location,
1593                           TREE_TYPE (TREE_TYPE (function)), fndecl,
1594                           nargs + 4, args);
1595   gfc_add_expr_to_block (&se->pre, tmp);
1596
1597   /* Free the temporary afterwards, if necessary.  */
1598   cond = fold_build2 (GT_EXPR, boolean_type_node,
1599                       len, build_int_cst (TREE_TYPE (len), 0));
1600   tmp = gfc_call_free (var);
1601   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1602   gfc_add_expr_to_block (&se->post, tmp);
1603
1604   se->expr = var;
1605   se->string_length = len;
1606 }
1607
1608
1609 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1610    has the generic name.  */
1611
1612 static gfc_symbol *
1613 gfc_get_symbol_for_expr (gfc_expr * expr)
1614 {
1615   gfc_symbol *sym;
1616
1617   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1618   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1619   sym = gfc_new_symbol (expr->value.function.name, NULL);
1620
1621   sym->ts = expr->ts;
1622   sym->attr.external = 1;
1623   sym->attr.function = 1;
1624   sym->attr.always_explicit = 1;
1625   sym->attr.proc = PROC_INTRINSIC;
1626   sym->attr.flavor = FL_PROCEDURE;
1627   sym->result = sym;
1628   if (expr->rank > 0)
1629     {
1630       sym->attr.dimension = 1;
1631       sym->as = gfc_get_array_spec ();
1632       sym->as->type = AS_ASSUMED_SHAPE;
1633       sym->as->rank = expr->rank;
1634     }
1635
1636   /* TODO: proper argument lists for external intrinsics.  */
1637   return sym;
1638 }
1639
1640 /* Generate a call to an external intrinsic function.  */
1641 static void
1642 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1643 {
1644   gfc_symbol *sym;
1645   tree append_args;
1646
1647   gcc_assert (!se->ss || se->ss->expr == expr);
1648
1649   if (se->ss)
1650     gcc_assert (expr->rank > 0);
1651   else
1652     gcc_assert (expr->rank == 0);
1653
1654   sym = gfc_get_symbol_for_expr (expr);
1655
1656   /* Calls to libgfortran_matmul need to be appended special arguments,
1657      to be able to call the BLAS ?gemm functions if required and possible.  */
1658   append_args = NULL_TREE;
1659   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1660       && sym->ts.type != BT_LOGICAL)
1661     {
1662       tree cint = gfc_get_int_type (gfc_c_int_kind);
1663
1664       if (gfc_option.flag_external_blas
1665           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1666           && (sym->ts.kind == gfc_default_real_kind
1667               || sym->ts.kind == gfc_default_double_kind))
1668         {
1669           tree gemm_fndecl;
1670
1671           if (sym->ts.type == BT_REAL)
1672             {
1673               if (sym->ts.kind == gfc_default_real_kind)
1674                 gemm_fndecl = gfor_fndecl_sgemm;
1675               else
1676                 gemm_fndecl = gfor_fndecl_dgemm;
1677             }
1678           else
1679             {
1680               if (sym->ts.kind == gfc_default_real_kind)
1681                 gemm_fndecl = gfor_fndecl_cgemm;
1682               else
1683                 gemm_fndecl = gfor_fndecl_zgemm;
1684             }
1685
1686           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1687           append_args = gfc_chainon_list
1688                           (append_args, build_int_cst
1689                                           (cint, gfc_option.blas_matmul_limit));
1690           append_args = gfc_chainon_list (append_args,
1691                                           gfc_build_addr_expr (NULL_TREE,
1692                                                                gemm_fndecl));
1693         }
1694       else
1695         {
1696           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1697           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1698           append_args = gfc_chainon_list (append_args, null_pointer_node);
1699         }
1700     }
1701
1702   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1703                           append_args);
1704   gfc_free (sym);
1705 }
1706
1707 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1708    Implemented as
1709     any(a)
1710     {
1711       forall (i=...)
1712         if (a[i] != 0)
1713           return 1
1714       end forall
1715       return 0
1716     }
1717     all(a)
1718     {
1719       forall (i=...)
1720         if (a[i] == 0)
1721           return 0
1722       end forall
1723       return 1
1724     }
1725  */
1726 static void
1727 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1728 {
1729   tree resvar;
1730   stmtblock_t block;
1731   stmtblock_t body;
1732   tree type;
1733   tree tmp;
1734   tree found;
1735   gfc_loopinfo loop;
1736   gfc_actual_arglist *actual;
1737   gfc_ss *arrayss;
1738   gfc_se arrayse;
1739   tree exit_label;
1740
1741   if (se->ss)
1742     {
1743       gfc_conv_intrinsic_funcall (se, expr);
1744       return;
1745     }
1746
1747   actual = expr->value.function.actual;
1748   type = gfc_typenode_for_spec (&expr->ts);
1749   /* Initialize the result.  */
1750   resvar = gfc_create_var (type, "test");
1751   if (op == EQ_EXPR)
1752     tmp = convert (type, boolean_true_node);
1753   else
1754     tmp = convert (type, boolean_false_node);
1755   gfc_add_modify (&se->pre, resvar, tmp);
1756
1757   /* Walk the arguments.  */
1758   arrayss = gfc_walk_expr (actual->expr);
1759   gcc_assert (arrayss != gfc_ss_terminator);
1760
1761   /* Initialize the scalarizer.  */
1762   gfc_init_loopinfo (&loop);
1763   exit_label = gfc_build_label_decl (NULL_TREE);
1764   TREE_USED (exit_label) = 1;
1765   gfc_add_ss_to_loop (&loop, arrayss);
1766
1767   /* Initialize the loop.  */
1768   gfc_conv_ss_startstride (&loop);
1769   gfc_conv_loop_setup (&loop, &expr->where);
1770
1771   gfc_mark_ss_chain_used (arrayss, 1);
1772   /* Generate the loop body.  */
1773   gfc_start_scalarized_body (&loop, &body);
1774
1775   /* If the condition matches then set the return value.  */
1776   gfc_start_block (&block);
1777   if (op == EQ_EXPR)
1778     tmp = convert (type, boolean_false_node);
1779   else
1780     tmp = convert (type, boolean_true_node);
1781   gfc_add_modify (&block, resvar, tmp);
1782
1783   /* And break out of the loop.  */
1784   tmp = build1_v (GOTO_EXPR, exit_label);
1785   gfc_add_expr_to_block (&block, tmp);
1786
1787   found = gfc_finish_block (&block);
1788
1789   /* Check this element.  */
1790   gfc_init_se (&arrayse, NULL);
1791   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1792   arrayse.ss = arrayss;
1793   gfc_conv_expr_val (&arrayse, actual->expr);
1794
1795   gfc_add_block_to_block (&body, &arrayse.pre);
1796   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1797                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1798   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1799   gfc_add_expr_to_block (&body, tmp);
1800   gfc_add_block_to_block (&body, &arrayse.post);
1801
1802   gfc_trans_scalarizing_loops (&loop, &body);
1803
1804   /* Add the exit label.  */
1805   tmp = build1_v (LABEL_EXPR, exit_label);
1806   gfc_add_expr_to_block (&loop.pre, tmp);
1807
1808   gfc_add_block_to_block (&se->pre, &loop.pre);
1809   gfc_add_block_to_block (&se->pre, &loop.post);
1810   gfc_cleanup_loop (&loop);
1811
1812   se->expr = resvar;
1813 }
1814
1815 /* COUNT(A) = Number of true elements in A.  */
1816 static void
1817 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1818 {
1819   tree resvar;
1820   tree type;
1821   stmtblock_t body;
1822   tree tmp;
1823   gfc_loopinfo loop;
1824   gfc_actual_arglist *actual;
1825   gfc_ss *arrayss;
1826   gfc_se arrayse;
1827
1828   if (se->ss)
1829     {
1830       gfc_conv_intrinsic_funcall (se, expr);
1831       return;
1832     }
1833
1834   actual = expr->value.function.actual;
1835
1836   type = gfc_typenode_for_spec (&expr->ts);
1837   /* Initialize the result.  */
1838   resvar = gfc_create_var (type, "count");
1839   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1840
1841   /* Walk the arguments.  */
1842   arrayss = gfc_walk_expr (actual->expr);
1843   gcc_assert (arrayss != gfc_ss_terminator);
1844
1845   /* Initialize the scalarizer.  */
1846   gfc_init_loopinfo (&loop);
1847   gfc_add_ss_to_loop (&loop, arrayss);
1848
1849   /* Initialize the loop.  */
1850   gfc_conv_ss_startstride (&loop);
1851   gfc_conv_loop_setup (&loop, &expr->where);
1852
1853   gfc_mark_ss_chain_used (arrayss, 1);
1854   /* Generate the loop body.  */
1855   gfc_start_scalarized_body (&loop, &body);
1856
1857   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1858                      resvar, build_int_cst (TREE_TYPE (resvar), 1));
1859   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1860
1861   gfc_init_se (&arrayse, NULL);
1862   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1863   arrayse.ss = arrayss;
1864   gfc_conv_expr_val (&arrayse, actual->expr);
1865   tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1866                   build_empty_stmt (input_location));
1867
1868   gfc_add_block_to_block (&body, &arrayse.pre);
1869   gfc_add_expr_to_block (&body, tmp);
1870   gfc_add_block_to_block (&body, &arrayse.post);
1871
1872   gfc_trans_scalarizing_loops (&loop, &body);
1873
1874   gfc_add_block_to_block (&se->pre, &loop.pre);
1875   gfc_add_block_to_block (&se->pre, &loop.post);
1876   gfc_cleanup_loop (&loop);
1877
1878   se->expr = resvar;
1879 }
1880
1881 /* Inline implementation of the sum and product intrinsics.  */
1882 static void
1883 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
1884 {
1885   tree resvar;
1886   tree type;
1887   stmtblock_t body;
1888   stmtblock_t block;
1889   tree tmp;
1890   gfc_loopinfo loop;
1891   gfc_actual_arglist *actual;
1892   gfc_ss *arrayss;
1893   gfc_ss *maskss;
1894   gfc_se arrayse;
1895   gfc_se maskse;
1896   gfc_expr *arrayexpr;
1897   gfc_expr *maskexpr;
1898
1899   if (se->ss)
1900     {
1901       gfc_conv_intrinsic_funcall (se, expr);
1902       return;
1903     }
1904
1905   type = gfc_typenode_for_spec (&expr->ts);
1906   /* Initialize the result.  */
1907   resvar = gfc_create_var (type, "val");
1908   if (op == PLUS_EXPR)
1909     tmp = gfc_build_const (type, integer_zero_node);
1910   else
1911     tmp = gfc_build_const (type, integer_one_node);
1912
1913   gfc_add_modify (&se->pre, resvar, tmp);
1914
1915   /* Walk the arguments.  */
1916   actual = expr->value.function.actual;
1917   arrayexpr = actual->expr;
1918   arrayss = gfc_walk_expr (arrayexpr);
1919   gcc_assert (arrayss != gfc_ss_terminator);
1920
1921   actual = actual->next->next;
1922   gcc_assert (actual);
1923   maskexpr = actual->expr;
1924   if (maskexpr && maskexpr->rank != 0)
1925     {
1926       maskss = gfc_walk_expr (maskexpr);
1927       gcc_assert (maskss != gfc_ss_terminator);
1928     }
1929   else
1930     maskss = NULL;
1931
1932   /* Initialize the scalarizer.  */
1933   gfc_init_loopinfo (&loop);
1934   gfc_add_ss_to_loop (&loop, arrayss);
1935   if (maskss)
1936     gfc_add_ss_to_loop (&loop, maskss);
1937
1938   /* Initialize the loop.  */
1939   gfc_conv_ss_startstride (&loop);
1940   gfc_conv_loop_setup (&loop, &expr->where);
1941
1942   gfc_mark_ss_chain_used (arrayss, 1);
1943   if (maskss)
1944     gfc_mark_ss_chain_used (maskss, 1);
1945   /* Generate the loop body.  */
1946   gfc_start_scalarized_body (&loop, &body);
1947
1948   /* If we have a mask, only add this element if the mask is set.  */
1949   if (maskss)
1950     {
1951       gfc_init_se (&maskse, NULL);
1952       gfc_copy_loopinfo_to_se (&maskse, &loop);
1953       maskse.ss = maskss;
1954       gfc_conv_expr_val (&maskse, maskexpr);
1955       gfc_add_block_to_block (&body, &maskse.pre);
1956
1957       gfc_start_block (&block);
1958     }
1959   else
1960     gfc_init_block (&block);
1961
1962   /* Do the actual summation/product.  */
1963   gfc_init_se (&arrayse, NULL);
1964   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1965   arrayse.ss = arrayss;
1966   gfc_conv_expr_val (&arrayse, arrayexpr);
1967   gfc_add_block_to_block (&block, &arrayse.pre);
1968
1969   tmp = fold_build2 (op, type, resvar, arrayse.expr);
1970   gfc_add_modify (&block, resvar, tmp);
1971   gfc_add_block_to_block (&block, &arrayse.post);
1972
1973   if (maskss)
1974     {
1975       /* We enclose the above in if (mask) {...} .  */
1976       tmp = gfc_finish_block (&block);
1977
1978       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1979                       build_empty_stmt (input_location));
1980     }
1981   else
1982     tmp = gfc_finish_block (&block);
1983   gfc_add_expr_to_block (&body, tmp);
1984
1985   gfc_trans_scalarizing_loops (&loop, &body);
1986
1987   /* For a scalar mask, enclose the loop in an if statement.  */
1988   if (maskexpr && maskss == NULL)
1989     {
1990       gfc_init_se (&maskse, NULL);
1991       gfc_conv_expr_val (&maskse, maskexpr);
1992       gfc_init_block (&block);
1993       gfc_add_block_to_block (&block, &loop.pre);
1994       gfc_add_block_to_block (&block, &loop.post);
1995       tmp = gfc_finish_block (&block);
1996
1997       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1998                       build_empty_stmt (input_location));
1999       gfc_add_expr_to_block (&block, tmp);
2000       gfc_add_block_to_block (&se->pre, &block);
2001     }
2002   else
2003     {
2004       gfc_add_block_to_block (&se->pre, &loop.pre);
2005       gfc_add_block_to_block (&se->pre, &loop.post);
2006     }
2007
2008   gfc_cleanup_loop (&loop);
2009
2010   se->expr = resvar;
2011 }
2012
2013
2014 /* Inline implementation of the dot_product intrinsic. This function
2015    is based on gfc_conv_intrinsic_arith (the previous function).  */
2016 static void
2017 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2018 {
2019   tree resvar;
2020   tree type;
2021   stmtblock_t body;
2022   stmtblock_t block;
2023   tree tmp;
2024   gfc_loopinfo loop;
2025   gfc_actual_arglist *actual;
2026   gfc_ss *arrayss1, *arrayss2;
2027   gfc_se arrayse1, arrayse2;
2028   gfc_expr *arrayexpr1, *arrayexpr2;
2029
2030   type = gfc_typenode_for_spec (&expr->ts);
2031
2032   /* Initialize the result.  */
2033   resvar = gfc_create_var (type, "val");
2034   if (expr->ts.type == BT_LOGICAL)
2035     tmp = build_int_cst (type, 0);
2036   else
2037     tmp = gfc_build_const (type, integer_zero_node);
2038
2039   gfc_add_modify (&se->pre, resvar, tmp);
2040
2041   /* Walk argument #1.  */
2042   actual = expr->value.function.actual;
2043   arrayexpr1 = actual->expr;
2044   arrayss1 = gfc_walk_expr (arrayexpr1);
2045   gcc_assert (arrayss1 != gfc_ss_terminator);
2046
2047   /* Walk argument #2.  */
2048   actual = actual->next;
2049   arrayexpr2 = actual->expr;
2050   arrayss2 = gfc_walk_expr (arrayexpr2);
2051   gcc_assert (arrayss2 != gfc_ss_terminator);
2052
2053   /* Initialize the scalarizer.  */
2054   gfc_init_loopinfo (&loop);
2055   gfc_add_ss_to_loop (&loop, arrayss1);
2056   gfc_add_ss_to_loop (&loop, arrayss2);
2057
2058   /* Initialize the loop.  */
2059   gfc_conv_ss_startstride (&loop);
2060   gfc_conv_loop_setup (&loop, &expr->where);
2061
2062   gfc_mark_ss_chain_used (arrayss1, 1);
2063   gfc_mark_ss_chain_used (arrayss2, 1);
2064
2065   /* Generate the loop body.  */
2066   gfc_start_scalarized_body (&loop, &body);
2067   gfc_init_block (&block);
2068
2069   /* Make the tree expression for [conjg(]array1[)].  */
2070   gfc_init_se (&arrayse1, NULL);
2071   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2072   arrayse1.ss = arrayss1;
2073   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2074   if (expr->ts.type == BT_COMPLEX)
2075     arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2076   gfc_add_block_to_block (&block, &arrayse1.pre);
2077
2078   /* Make the tree expression for array2.  */
2079   gfc_init_se (&arrayse2, NULL);
2080   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2081   arrayse2.ss = arrayss2;
2082   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2083   gfc_add_block_to_block (&block, &arrayse2.pre);
2084
2085   /* Do the actual product and sum.  */
2086   if (expr->ts.type == BT_LOGICAL)
2087     {
2088       tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2089       tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2090     }
2091   else
2092     {
2093       tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2094       tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2095     }
2096   gfc_add_modify (&block, resvar, tmp);
2097
2098   /* Finish up the loop block and the loop.  */
2099   tmp = gfc_finish_block (&block);
2100   gfc_add_expr_to_block (&body, tmp);
2101
2102   gfc_trans_scalarizing_loops (&loop, &body);
2103   gfc_add_block_to_block (&se->pre, &loop.pre);
2104   gfc_add_block_to_block (&se->pre, &loop.post);
2105   gfc_cleanup_loop (&loop);
2106
2107   se->expr = resvar;
2108 }
2109
2110
2111 /* Emit code for minloc or maxloc intrinsic.  There are many different cases
2112    we need to handle.  For performance reasons we sometimes create two
2113    loops instead of one, where the second one is much simpler.
2114    Examples for minloc intrinsic:
2115    1) Result is an array, a call is generated
2116    2) Array mask is used and NaNs need to be supported:
2117       limit = Infinity;
2118       pos = 0;
2119       S = from;
2120       while (S <= to) {
2121         if (mask[S]) {
2122           if (pos == 0) pos = S + (1 - from);
2123           if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2124         }
2125         S++;
2126       }
2127       goto lab2;
2128       lab1:;
2129       while (S <= to) {
2130         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2131         S++;
2132       }
2133       lab2:;
2134    3) NaNs need to be supported, but it is known at compile time or cheaply
2135       at runtime whether array is nonempty or not:
2136       limit = Infinity;
2137       pos = 0;
2138       S = from;
2139       while (S <= to) {
2140         if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2141         S++;
2142       }
2143       if (from <= to) pos = 1;
2144       goto lab2;
2145       lab1:;
2146       while (S <= to) {
2147         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2148         S++;
2149       }
2150       lab2:;
2151    4) NaNs aren't supported, array mask is used:
2152       limit = infinities_supported ? Infinity : huge (limit);
2153       pos = 0;
2154       S = from;
2155       while (S <= to) {
2156         if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2157         S++;
2158       }
2159       goto lab2;
2160       lab1:;
2161       while (S <= to) {
2162         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2163         S++;
2164       }
2165       lab2:;
2166    5) Same without array mask:
2167       limit = infinities_supported ? Infinity : huge (limit);
2168       pos = (from <= to) ? 1 : 0;
2169       S = from;
2170       while (S <= to) {
2171         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2172         S++;
2173       }
2174    For 3) and 5), if mask is scalar, this all goes into a conditional,
2175    setting pos = 0; in the else branch.  */
2176
2177 static void
2178 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2179 {
2180   stmtblock_t body;
2181   stmtblock_t block;
2182   stmtblock_t ifblock;
2183   stmtblock_t elseblock;
2184   tree limit;
2185   tree type;
2186   tree tmp;
2187   tree cond;
2188   tree elsetmp;
2189   tree ifbody;
2190   tree offset;
2191   tree nonempty;
2192   tree lab1, lab2;
2193   gfc_loopinfo loop;
2194   gfc_actual_arglist *actual;
2195   gfc_ss *arrayss;
2196   gfc_ss *maskss;
2197   gfc_se arrayse;
2198   gfc_se maskse;
2199   gfc_expr *arrayexpr;
2200   gfc_expr *maskexpr;
2201   tree pos;
2202   int n;
2203
2204   if (se->ss)
2205     {
2206       gfc_conv_intrinsic_funcall (se, expr);
2207       return;
2208     }
2209
2210   /* Initialize the result.  */
2211   pos = gfc_create_var (gfc_array_index_type, "pos");
2212   offset = gfc_create_var (gfc_array_index_type, "offset");
2213   type = gfc_typenode_for_spec (&expr->ts);
2214
2215   /* Walk the arguments.  */
2216   actual = expr->value.function.actual;
2217   arrayexpr = actual->expr;
2218   arrayss = gfc_walk_expr (arrayexpr);
2219   gcc_assert (arrayss != gfc_ss_terminator);
2220
2221   actual = actual->next->next;
2222   gcc_assert (actual);
2223   maskexpr = actual->expr;
2224   nonempty = NULL;
2225   if (maskexpr && maskexpr->rank != 0)
2226     {
2227       maskss = gfc_walk_expr (maskexpr);
2228       gcc_assert (maskss != gfc_ss_terminator);
2229     }
2230   else
2231     {
2232       mpz_t asize;
2233       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2234         {
2235           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2236           mpz_clear (asize);
2237           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2238                                   gfc_index_zero_node);
2239         }
2240       maskss = NULL;
2241     }
2242
2243   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2244   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2245   switch (arrayexpr->ts.type)
2246     {
2247     case BT_REAL:
2248       if (HONOR_INFINITIES (DECL_MODE (limit)))
2249         {
2250           REAL_VALUE_TYPE real;
2251           real_inf (&real);
2252           tmp = build_real (TREE_TYPE (limit), real);
2253         }
2254       else
2255         tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2256                                      arrayexpr->ts.kind, 0);
2257       break;
2258
2259     case BT_INTEGER:
2260       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2261                                   arrayexpr->ts.kind);
2262       break;
2263
2264     default:
2265       gcc_unreachable ();
2266     }
2267
2268   /* We start with the most negative possible value for MAXLOC, and the most
2269      positive possible value for MINLOC. The most negative possible value is
2270      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2271      possible value is HUGE in both cases.  */
2272   if (op == GT_EXPR)
2273     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2274   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2275     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2276                        build_int_cst (type, 1));
2277
2278   gfc_add_modify (&se->pre, limit, tmp);
2279
2280   /* Initialize the scalarizer.  */
2281   gfc_init_loopinfo (&loop);
2282   gfc_add_ss_to_loop (&loop, arrayss);
2283   if (maskss)
2284     gfc_add_ss_to_loop (&loop, maskss);
2285
2286   /* Initialize the loop.  */
2287   gfc_conv_ss_startstride (&loop);
2288   gfc_conv_loop_setup (&loop, &expr->where);
2289
2290   gcc_assert (loop.dimen == 1);
2291   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2292     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2293                             loop.to[0]);
2294
2295   lab1 = NULL;
2296   lab2 = NULL;
2297   /* Initialize the position to zero, following Fortran 2003.  We are free
2298      to do this because Fortran 95 allows the result of an entirely false
2299      mask to be processor dependent.  If we know at compile time the array
2300      is non-empty and no MASK is used, we can initialize to 1 to simplify
2301      the inner loop.  */
2302   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2303     gfc_add_modify (&loop.pre, pos,
2304                     fold_build3 (COND_EXPR, gfc_array_index_type,
2305                                  nonempty, gfc_index_one_node,
2306                                  gfc_index_zero_node));
2307   else
2308     {
2309       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2310       lab1 = gfc_build_label_decl (NULL_TREE);
2311       TREE_USED (lab1) = 1;
2312       lab2 = gfc_build_label_decl (NULL_TREE);
2313       TREE_USED (lab2) = 1;
2314     }
2315
2316   gfc_mark_ss_chain_used (arrayss, 1);
2317   if (maskss)
2318     gfc_mark_ss_chain_used (maskss, 1);
2319   /* Generate the loop body.  */
2320   gfc_start_scalarized_body (&loop, &body);
2321
2322   /* If we have a mask, only check this element if the mask is set.  */
2323   if (maskss)
2324     {
2325       gfc_init_se (&maskse, NULL);
2326       gfc_copy_loopinfo_to_se (&maskse, &loop);
2327       maskse.ss = maskss;
2328       gfc_conv_expr_val (&maskse, maskexpr);
2329       gfc_add_block_to_block (&body, &maskse.pre);
2330
2331       gfc_start_block (&block);
2332     }
2333   else
2334     gfc_init_block (&block);
2335
2336   /* Compare with the current limit.  */
2337   gfc_init_se (&arrayse, NULL);
2338   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2339   arrayse.ss = arrayss;
2340   gfc_conv_expr_val (&arrayse, arrayexpr);
2341   gfc_add_block_to_block (&block, &arrayse.pre);
2342
2343   /* We do the following if this is a more extreme value.  */
2344   gfc_start_block (&ifblock);
2345
2346   /* Assign the value to the limit...  */
2347   gfc_add_modify (&ifblock, limit, arrayse.expr);
2348
2349   /* Remember where we are.  An offset must be added to the loop
2350      counter to obtain the required position.  */
2351   if (loop.from[0])
2352     tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2353                        gfc_index_one_node, loop.from[0]);
2354   else
2355     tmp = gfc_index_one_node;
2356
2357   gfc_add_modify (&block, offset, tmp);
2358
2359   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2360     {
2361       stmtblock_t ifblock2;
2362       tree ifbody2;
2363
2364       gfc_start_block (&ifblock2);
2365       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2366                          loop.loopvar[0], offset);
2367       gfc_add_modify (&ifblock2, pos, tmp);
2368       ifbody2 = gfc_finish_block (&ifblock2);
2369       cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
2370                           gfc_index_zero_node);
2371       tmp = build3_v (COND_EXPR, cond, ifbody2,
2372                       build_empty_stmt (input_location));
2373       gfc_add_expr_to_block (&block, tmp);
2374     }
2375
2376   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2377                      loop.loopvar[0], offset);
2378   gfc_add_modify (&ifblock, pos, tmp);
2379
2380   if (lab1)
2381     gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2382
2383   ifbody = gfc_finish_block (&ifblock);
2384
2385   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2386     {
2387       if (lab1)
2388         cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2389                             boolean_type_node, arrayse.expr, limit);
2390       else
2391         cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2392
2393       ifbody = build3_v (COND_EXPR, cond, ifbody,
2394                          build_empty_stmt (input_location));
2395     }
2396   gfc_add_expr_to_block (&block, ifbody);
2397
2398   if (maskss)
2399     {
2400       /* We enclose the above in if (mask) {...}.  */
2401       tmp = gfc_finish_block (&block);
2402
2403       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2404                       build_empty_stmt (input_location));
2405     }
2406   else
2407     tmp = gfc_finish_block (&block);
2408   gfc_add_expr_to_block (&body, tmp);
2409
2410   if (lab1)
2411     {
2412       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2413
2414       if (HONOR_NANS (DECL_MODE (limit)))
2415         {
2416           if (nonempty != NULL)
2417             {
2418               ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2419               tmp = build3_v (COND_EXPR, nonempty, ifbody,
2420                               build_empty_stmt (input_location));
2421               gfc_add_expr_to_block (&loop.code[0], tmp);
2422             }
2423         }
2424
2425       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2426       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2427       gfc_start_block (&body);
2428
2429       /* If we have a mask, only check this element if the mask is set.  */
2430       if (maskss)
2431         {
2432           gfc_init_se (&maskse, NULL);
2433           gfc_copy_loopinfo_to_se (&maskse, &loop);
2434           maskse.ss = maskss;
2435           gfc_conv_expr_val (&maskse, maskexpr);
2436           gfc_add_block_to_block (&body, &maskse.pre);
2437
2438           gfc_start_block (&block);
2439         }
2440       else
2441         gfc_init_block (&block);
2442
2443       /* Compare with the current limit.  */
2444       gfc_init_se (&arrayse, NULL);
2445       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2446       arrayse.ss = arrayss;
2447       gfc_conv_expr_val (&arrayse, arrayexpr);
2448       gfc_add_block_to_block (&block, &arrayse.pre);
2449
2450       /* We do the following if this is a more extreme value.  */
2451       gfc_start_block (&ifblock);
2452
2453       /* Assign the value to the limit...  */
2454       gfc_add_modify (&ifblock, limit, arrayse.expr);
2455
2456       /* Remember where we are.  An offset must be added to the loop
2457          counter to obtain the required position.  */
2458       if (loop.from[0])
2459         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2460                            gfc_index_one_node, loop.from[0]);
2461       else
2462         tmp = gfc_index_one_node;
2463
2464       gfc_add_modify (&block, offset, tmp);
2465
2466       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2467                          loop.loopvar[0], offset);
2468       gfc_add_modify (&ifblock, pos, tmp);
2469
2470       ifbody = gfc_finish_block (&ifblock);
2471
2472       cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2473
2474       tmp = build3_v (COND_EXPR, cond, ifbody,
2475                       build_empty_stmt (input_location));
2476       gfc_add_expr_to_block (&block, tmp);
2477
2478       if (maskss)
2479         {
2480           /* We enclose the above in if (mask) {...}.  */
2481           tmp = gfc_finish_block (&block);
2482
2483           tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2484                           build_empty_stmt (input_location));
2485         }
2486       else
2487         tmp = gfc_finish_block (&block);
2488       gfc_add_expr_to_block (&body, tmp);
2489       /* Avoid initializing loopvar[0] again, it should be left where
2490          it finished by the first loop.  */
2491       loop.from[0] = loop.loopvar[0];
2492     }
2493
2494   gfc_trans_scalarizing_loops (&loop, &body);
2495
2496   if (lab2)
2497     gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2498
2499   /* For a scalar mask, enclose the loop in an if statement.  */
2500   if (maskexpr && maskss == NULL)
2501     {
2502       gfc_init_se (&maskse, NULL);
2503       gfc_conv_expr_val (&maskse, maskexpr);
2504       gfc_init_block (&block);
2505       gfc_add_block_to_block (&block, &loop.pre);
2506       gfc_add_block_to_block (&block, &loop.post);
2507       tmp = gfc_finish_block (&block);
2508
2509       /* For the else part of the scalar mask, just initialize
2510          the pos variable the same way as above.  */
2511
2512       gfc_init_block (&elseblock);
2513       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2514       elsetmp = gfc_finish_block (&elseblock);
2515
2516       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2517       gfc_add_expr_to_block (&block, tmp);
2518       gfc_add_block_to_block (&se->pre, &block);
2519     }
2520   else
2521     {
2522       gfc_add_block_to_block (&se->pre, &loop.pre);
2523       gfc_add_block_to_block (&se->pre, &loop.post);
2524     }
2525   gfc_cleanup_loop (&loop);
2526
2527   se->expr = convert (type, pos);
2528 }
2529
2530 /* Emit code for minval or maxval intrinsic.  There are many different cases
2531    we need to handle.  For performance reasons we sometimes create two
2532    loops instead of one, where the second one is much simpler.
2533    Examples for minval intrinsic:
2534    1) Result is an array, a call is generated
2535    2) Array mask is used and NaNs need to be supported, rank 1:
2536       limit = Infinity;
2537       nonempty = false;
2538       S = from;
2539       while (S <= to) {
2540         if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2541         S++;
2542       }
2543       limit = nonempty ? NaN : huge (limit);
2544       lab:
2545       while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2546    3) NaNs need to be supported, but it is known at compile time or cheaply
2547       at runtime whether array is nonempty or not, rank 1:
2548       limit = Infinity;
2549       S = from;
2550       while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2551       limit = (from <= to) ? NaN : huge (limit);
2552       lab:
2553       while (S <= to) { limit = min (a[S], limit); S++; }
2554    4) Array mask is used and NaNs need to be supported, rank > 1:
2555       limit = Infinity;
2556       nonempty = false;
2557       fast = false;
2558       S1 = from1;
2559       while (S1 <= to1) {
2560         S2 = from2;
2561         while (S2 <= to2) {
2562           if (mask[S1][S2]) {
2563             if (fast) limit = min (a[S1][S2], limit);
2564             else {
2565               nonempty = true;
2566               if (a[S1][S2] <= limit) {
2567                 limit = a[S1][S2];
2568                 fast = true;
2569               }
2570             }
2571           }
2572           S2++;
2573         }
2574         S1++;
2575       }
2576       if (!fast)
2577         limit = nonempty ? NaN : huge (limit);
2578    5) NaNs need to be supported, but it is known at compile time or cheaply
2579       at runtime whether array is nonempty or not, rank > 1:
2580       limit = Infinity;
2581       fast = false;
2582       S1 = from1;
2583       while (S1 <= to1) {
2584         S2 = from2;
2585         while (S2 <= to2) {
2586           if (fast) limit = min (a[S1][S2], limit);
2587           else {
2588             if (a[S1][S2] <= limit) {
2589               limit = a[S1][S2];
2590               fast = true;
2591             }
2592           }
2593           S2++;
2594         }
2595         S1++;
2596       }
2597       if (!fast)
2598         limit = (nonempty_array) ? NaN : huge (limit);
2599    6) NaNs aren't supported, but infinities are.  Array mask is used:
2600       limit = Infinity;
2601       nonempty = false;
2602       S = from;
2603       while (S <= to) {
2604         if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2605         S++;
2606       }
2607       limit = nonempty ? limit : huge (limit);
2608    7) Same without array mask:
2609       limit = Infinity;
2610       S = from;
2611       while (S <= to) { limit = min (a[S], limit); S++; }
2612       limit = (from <= to) ? limit : huge (limit);
2613    8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2614       limit = huge (limit);
2615       S = from;
2616       while (S <= to) { limit = min (a[S], limit); S++); }
2617       (or
2618       while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2619       with array mask instead).
2620    For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2621    setting limit = huge (limit); in the else branch.  */
2622
2623 static void
2624 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2625 {
2626   tree limit;
2627   tree type;
2628   tree tmp;
2629   tree ifbody;
2630   tree nonempty;
2631   tree nonempty_var;
2632   tree lab;
2633   tree fast;
2634   tree huge_cst = NULL, nan_cst = NULL;
2635   stmtblock_t body;
2636   stmtblock_t block, block2;
2637   gfc_loopinfo loop;
2638   gfc_actual_arglist *actual;
2639   gfc_ss *arrayss;
2640   gfc_ss *maskss;
2641   gfc_se arrayse;
2642   gfc_se maskse;
2643   gfc_expr *arrayexpr;
2644   gfc_expr *maskexpr;
2645   int n;
2646
2647   if (se->ss)
2648     {
2649       gfc_conv_intrinsic_funcall (se, expr);
2650       return;
2651     }
2652
2653   type = gfc_typenode_for_spec (&expr->ts);
2654   /* Initialize the result.  */
2655   limit = gfc_create_var (type, "limit");
2656   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2657   switch (expr->ts.type)
2658     {
2659     case BT_REAL:
2660       huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2661                                         expr->ts.kind, 0);
2662       if (HONOR_INFINITIES (DECL_MODE (limit)))
2663         {
2664           REAL_VALUE_TYPE real;
2665           real_inf (&real);
2666           tmp = build_real (type, real);
2667         }
2668       else
2669         tmp = huge_cst;
2670       if (HONOR_NANS (DECL_MODE (limit)))
2671         {
2672           REAL_VALUE_TYPE real;
2673           real_nan (&real, "", 1, DECL_MODE (limit));
2674           nan_cst = build_real (type, real);
2675         }
2676       break;
2677
2678     case BT_INTEGER:
2679       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2680       break;
2681
2682     default:
2683       gcc_unreachable ();
2684     }
2685
2686   /* We start with the most negative possible value for MAXVAL, and the most
2687      positive possible value for MINVAL. The most negative possible value is
2688      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2689      possible value is HUGE in both cases.  */
2690   if (op == GT_EXPR)
2691     {
2692       tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2693       if (huge_cst)
2694         huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
2695     }
2696
2697   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2698     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2699                        tmp, build_int_cst (type, 1));
2700
2701   gfc_add_modify (&se->pre, limit, tmp);
2702
2703   /* Walk the arguments.  */
2704   actual = expr->value.function.actual;
2705   arrayexpr = actual->expr;
2706   arrayss = gfc_walk_expr (arrayexpr);
2707   gcc_assert (arrayss != gfc_ss_terminator);
2708
2709   actual = actual->next->next;
2710   gcc_assert (actual);
2711   maskexpr = actual->expr;
2712   nonempty = NULL;
2713   if (maskexpr && maskexpr->rank != 0)
2714     {
2715       maskss = gfc_walk_expr (maskexpr);
2716       gcc_assert (maskss != gfc_ss_terminator);
2717     }
2718   else
2719     {
2720       mpz_t asize;
2721       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2722         {
2723           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2724           mpz_clear (asize);
2725           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2726                                   gfc_index_zero_node);
2727         }
2728       maskss = NULL;
2729     }
2730
2731   /* Initialize the scalarizer.  */
2732   gfc_init_loopinfo (&loop);
2733   gfc_add_ss_to_loop (&loop, arrayss);
2734   if (maskss)
2735     gfc_add_ss_to_loop (&loop, maskss);
2736
2737   /* Initialize the loop.  */
2738   gfc_conv_ss_startstride (&loop);
2739   gfc_conv_loop_setup (&loop, &expr->where);
2740
2741   if (nonempty == NULL && maskss == NULL
2742       && loop.dimen == 1 && loop.from[0] && loop.to[0])
2743     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2744                             loop.to[0]);
2745   nonempty_var = NULL;
2746   if (nonempty == NULL
2747       && (HONOR_INFINITIES (DECL_MODE (limit))
2748           || HONOR_NANS (DECL_MODE (limit))))
2749     {
2750       nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2751       gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2752       nonempty = nonempty_var;
2753     }
2754   lab = NULL;
2755   fast = NULL;
2756   if (HONOR_NANS (DECL_MODE (limit)))
2757     {
2758       if (loop.dimen == 1)
2759         {
2760           lab = gfc_build_label_decl (NULL_TREE);
2761           TREE_USED (lab) = 1;
2762         }
2763       else
2764         {
2765           fast = gfc_create_var (boolean_type_node, "fast");
2766           gfc_add_modify (&se->pre, fast, boolean_false_node);
2767         }
2768     }
2769
2770   gfc_mark_ss_chain_used (arrayss, 1);
2771   if (maskss)
2772     gfc_mark_ss_chain_used (maskss, 1);
2773   /* Generate the loop body.  */
2774   gfc_start_scalarized_body (&loop, &body);
2775
2776   /* If we have a mask, only add this element if the mask is set.  */
2777   if (maskss)
2778     {
2779       gfc_init_se (&maskse, NULL);
2780       gfc_copy_loopinfo_to_se (&maskse, &loop);
2781       maskse.ss = maskss;
2782       gfc_conv_expr_val (&maskse, maskexpr);
2783       gfc_add_block_to_block (&body, &maskse.pre);
2784
2785       gfc_start_block (&block);
2786     }
2787   else
2788     gfc_init_block (&block);
2789
2790   /* Compare with the current limit.  */
2791   gfc_init_se (&arrayse, NULL);
2792   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2793   arrayse.ss = arrayss;
2794   gfc_conv_expr_val (&arrayse, arrayexpr);
2795   gfc_add_block_to_block (&block, &arrayse.pre);
2796
2797   gfc_init_block (&block2);
2798
2799   if (nonempty_var)
2800     gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2801
2802   if (HONOR_NANS (DECL_MODE (limit)))
2803     {
2804       tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2805                          boolean_type_node, arrayse.expr, limit);
2806       if (lab)
2807         ifbody = build1_v (GOTO_EXPR, lab);
2808       else
2809         {
2810           stmtblock_t ifblock;
2811
2812           gfc_init_block (&ifblock);
2813           gfc_add_modify (&ifblock, limit, arrayse.expr);
2814           gfc_add_modify (&ifblock, fast, boolean_true_node);
2815           ifbody = gfc_finish_block (&ifblock);
2816         }
2817       tmp = build3_v (COND_EXPR, tmp, ifbody,
2818                       build_empty_stmt (input_location));
2819       gfc_add_expr_to_block (&block2, tmp);
2820     }
2821   else
2822     {
2823       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2824          signed zeros.  */
2825       if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2826         {
2827           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2828           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2829           tmp = build3_v (COND_EXPR, tmp, ifbody,
2830                           build_empty_stmt (input_location));
2831           gfc_add_expr_to_block (&block2, tmp);
2832         }
2833       else
2834         {
2835           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2836                              type, arrayse.expr, limit);
2837           gfc_add_modify (&block2, limit, tmp);
2838         }
2839     }
2840
2841   if (fast)
2842     {
2843       tree elsebody = gfc_finish_block (&block2);
2844
2845       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2846          signed zeros.  */
2847       if (HONOR_NANS (DECL_MODE (limit))
2848           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2849         {
2850           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2851           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2852           ifbody = build3_v (COND_EXPR, tmp, ifbody,
2853                              build_empty_stmt (input_location));
2854         }
2855       else
2856         {
2857           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2858                              type, arrayse.expr, limit);
2859           ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2860         }
2861       tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
2862       gfc_add_expr_to_block (&block, tmp);
2863     }
2864   else
2865     gfc_add_block_to_block (&block, &block2);
2866
2867   gfc_add_block_to_block (&block, &arrayse.post);
2868
2869   tmp = gfc_finish_block (&block);
2870   if (maskss)
2871     /* We enclose the above in if (mask) {...}.  */
2872     tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2873                     build_empty_stmt (input_location));
2874   gfc_add_expr_to_block (&body, tmp);
2875
2876   if (lab)
2877     {
2878       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2879
2880       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2881       gfc_add_modify (&loop.code[0], limit, tmp);
2882       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
2883
2884       gfc_start_block (&body);
2885
2886       /* If we have a mask, only add this element if the mask is set.  */
2887       if (maskss)
2888         {
2889           gfc_init_se (&maskse, NULL);
2890           gfc_copy_loopinfo_to_se (&maskse, &loop);
2891           maskse.ss = maskss;
2892           gfc_conv_expr_val (&maskse, maskexpr);
2893           gfc_add_block_to_block (&body, &maskse.pre);
2894
2895           gfc_start_block (&block);
2896         }
2897       else
2898         gfc_init_block (&block);
2899
2900       /* Compare with the current limit.  */
2901       gfc_init_se (&arrayse, NULL);
2902       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2903       arrayse.ss = arrayss;
2904       gfc_conv_expr_val (&arrayse, arrayexpr);
2905       gfc_add_block_to_block (&block, &arrayse.pre);
2906
2907       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2908          signed zeros.  */
2909       if (HONOR_NANS (DECL_MODE (limit))
2910           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2911         {
2912           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2913           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2914           tmp = build3_v (COND_EXPR, tmp, ifbody,
2915                           build_empty_stmt (input_location));
2916           gfc_add_expr_to_block (&block, tmp);
2917         }
2918       else
2919         {
2920           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2921                              type, arrayse.expr, limit);
2922           gfc_add_modify (&block, limit, tmp);
2923         }
2924
2925       gfc_add_block_to_block (&block, &arrayse.post);
2926
2927       tmp = gfc_finish_block (&block);
2928       if (maskss)
2929         /* We enclose the above in if (mask) {...}.  */
2930         tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2931                         build_empty_stmt (input_location));
2932       gfc_add_expr_to_block (&body, tmp);
2933       /* Avoid initializing loopvar[0] again, it should be left where
2934          it finished by the first loop.  */
2935       loop.from[0] = loop.loopvar[0];
2936     }
2937   gfc_trans_scalarizing_loops (&loop, &body);
2938
2939   if (fast)
2940     {
2941       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2942       ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2943       tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
2944                       ifbody);
2945       gfc_add_expr_to_block (&loop.pre, tmp);
2946     }
2947   else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
2948     {
2949       tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
2950       gfc_add_modify (&loop.pre, limit, tmp);
2951     }
2952
2953   /* For a scalar mask, enclose the loop in an if statement.  */
2954   if (maskexpr && maskss == NULL)
2955     {
2956       tree else_stmt;
2957
2958       gfc_init_se (&maskse, NULL);
2959       gfc_conv_expr_val (&maskse, maskexpr);
2960       gfc_init_block (&block);
2961       gfc_add_block_to_block (&block, &loop.pre);
2962       gfc_add_block_to_block (&block, &loop.post);
2963       tmp = gfc_finish_block (&block);
2964
2965       if (HONOR_INFINITIES (DECL_MODE (limit)))
2966         else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
2967       else
2968         else_stmt = build_empty_stmt (input_location);
2969       tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
2970       gfc_add_expr_to_block (&block, tmp);
2971       gfc_add_block_to_block (&se->pre, &block);
2972     }
2973   else
2974     {
2975       gfc_add_block_to_block (&se->pre, &loop.pre);
2976       gfc_add_block_to_block (&se->pre, &loop.post);
2977     }
2978
2979   gfc_cleanup_loop (&loop);
2980
2981   se->expr = limit;
2982 }
2983
2984 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2985 static void
2986 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2987 {
2988   tree args[2];
2989   tree type;
2990   tree tmp;
2991
2992   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2993   type = TREE_TYPE (args[0]);
2994
2995   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2996   tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2997   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2998                      build_int_cst (type, 0));
2999   type = gfc_typenode_for_spec (&expr->ts);
3000   se->expr = convert (type, tmp);
3001 }
3002
3003 /* Generate code to perform the specified operation.  */
3004 static void
3005 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3006 {
3007   tree args[2];
3008
3009   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3010   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
3011 }
3012
3013 /* Bitwise not.  */
3014 static void
3015 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3016 {
3017   tree arg;
3018
3019   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3020   se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
3021 }
3022
3023 /* Set or clear a single bit.  */
3024 static void
3025 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3026 {
3027   tree args[2];
3028   tree type;
3029   tree tmp;
3030   enum tree_code op;
3031
3032   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3033   type = TREE_TYPE (args[0]);
3034
3035   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3036   if (set)
3037     op = BIT_IOR_EXPR;
3038   else
3039     {
3040       op = BIT_AND_EXPR;
3041       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
3042     }
3043   se->expr = fold_build2 (op, type, args[0], tmp);
3044 }
3045
3046 /* Extract a sequence of bits.
3047     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
3048 static void
3049 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3050 {
3051   tree args[3];
3052   tree type;
3053   tree tmp;
3054   tree mask;
3055
3056   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3057   type = TREE_TYPE (args[0]);
3058
3059   mask = build_int_cst (type, -1);
3060   mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
3061   mask = fold_build1 (BIT_NOT_EXPR, type, mask);
3062
3063   tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
3064
3065   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
3066 }
3067
3068 /* RSHIFT (I, SHIFT) = I >> SHIFT
3069    LSHIFT (I, SHIFT) = I << SHIFT  */
3070 static void
3071 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3072 {
3073   tree args[2];
3074
3075   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3076
3077   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3078                           TREE_TYPE (args[0]), args[0], args[1]);
3079 }
3080
3081 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3082                         ? 0
3083                         : ((shift >= 0) ? i << shift : i >> -shift)
3084    where all shifts are logical shifts.  */
3085 static void
3086 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3087 {
3088   tree args[2];
3089   tree type;
3090   tree utype;
3091   tree tmp;
3092   tree width;
3093   tree num_bits;
3094   tree cond;
3095   tree lshift;
3096   tree rshift;
3097
3098   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3099   type = TREE_TYPE (args[0]);
3100   utype = unsigned_type_for (type);
3101
3102   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
3103
3104   /* Left shift if positive.  */
3105   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
3106
3107   /* Right shift if negative.
3108      We convert to an unsigned type because we want a logical shift.
3109      The standard doesn't define the case of shifting negative
3110      numbers, and we try to be compatible with other compilers, most
3111      notably g77, here.  */
3112   rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype, 
3113                                             convert (utype, args[0]), width));
3114
3115   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
3116                      build_int_cst (TREE_TYPE (args[1]), 0));
3117   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
3118
3119   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3120      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3121      special case.  */
3122   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3123   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
3124
3125   se->expr = fold_build3 (COND_EXPR, type, cond,
3126                           build_int_cst (type, 0), tmp);
3127 }
3128
3129
3130 /* Circular shift.  AKA rotate or barrel shift.  */
3131
3132 static void
3133 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3134 {
3135   tree *args;
3136   tree type;
3137   tree tmp;
3138   tree lrot;
3139   tree rrot;
3140   tree zero;
3141   unsigned int num_args;
3142
3143   num_args = gfc_intrinsic_argument_list_length (expr);
3144   args = (tree *) alloca (sizeof (tree) * num_args);
3145
3146   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3147
3148   if (num_args == 3)
3149     {
3150       /* Use a library function for the 3 parameter version.  */
3151       tree int4type = gfc_get_int_type (4);
3152
3153       type = TREE_TYPE (args[0]);
3154       /* We convert the first argument to at least 4 bytes, and
3155          convert back afterwards.  This removes the need for library
3156          functions for all argument sizes, and function will be
3157          aligned to at least 32 bits, so there's no loss.  */
3158       if (expr->ts.kind < 4)
3159         args[0] = convert (int4type, args[0]);
3160
3161       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3162          need loads of library  functions.  They cannot have values >
3163          BIT_SIZE (I) so the conversion is safe.  */
3164       args[1] = convert (int4type, args[1]);
3165       args[2] = convert (int4type, args[2]);
3166
3167       switch (expr->ts.kind)
3168         {
3169         case 1:
3170         case 2:
3171         case 4:
3172           tmp = gfor_fndecl_math_ishftc4;
3173           break;
3174         case 8:
3175           tmp = gfor_fndecl_math_ishftc8;
3176           break;
3177         case 16:
3178           tmp = gfor_fndecl_math_ishftc16;
3179           break;
3180         default:
3181           gcc_unreachable ();
3182         }
3183       se->expr = build_call_expr_loc (input_location,
3184                                   tmp, 3, args[0], args[1], args[2]);
3185       /* Convert the result back to the original type, if we extended
3186          the first argument's width above.  */
3187       if (expr->ts.kind < 4)
3188         se->expr = convert (type, se->expr);
3189
3190       return;
3191     }
3192   type = TREE_TYPE (args[0]);
3193
3194   /* Rotate left if positive.  */
3195   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
3196
3197   /* Rotate right if negative.  */
3198   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
3199   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
3200
3201   zero = build_int_cst (TREE_TYPE (args[1]), 0);
3202   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
3203   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
3204
3205   /* Do nothing if shift == 0.  */
3206   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
3207   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
3208 }
3209
3210 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3211                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3212
3213    The conditional expression is necessary because the result of LEADZ(0)
3214    is defined, but the result of __builtin_clz(0) is undefined for most
3215    targets.
3216
3217    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3218    difference in bit size between the argument of LEADZ and the C int.  */
3219  
3220 static void
3221 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3222 {
3223   tree arg;
3224   tree arg_type;
3225   tree cond;
3226   tree result_type;
3227   tree leadz;
3228   tree bit_size;
3229   tree tmp;
3230   tree func;
3231   int s, argsize;
3232
3233   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3234   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3235
3236   /* Which variant of __builtin_clz* should we call?  */
3237   if (argsize <= INT_TYPE_SIZE)
3238     {
3239       arg_type = unsigned_type_node;
3240       func = built_in_decls[BUILT_IN_CLZ];
3241     }
3242   else if (argsize <= LONG_TYPE_SIZE)
3243     {
3244       arg_type = long_unsigned_type_node;
3245       func = built_in_decls[BUILT_IN_CLZL];
3246     }
3247   else if (argsize <= LONG_LONG_TYPE_SIZE)
3248     {
3249       arg_type = long_long_unsigned_type_node;
3250       func = built_in_decls[BUILT_IN_CLZLL];
3251     }
3252   else
3253     {
3254       gcc_assert (argsize == 128);
3255       arg_type = gfc_build_uint_type (argsize);
3256       func = gfor_fndecl_clz128;
3257     }
3258
3259   /* Convert the actual argument twice: first, to the unsigned type of the
3260      same size; then, to the proper argument type for the built-in
3261      function.  But the return type is of the default INTEGER kind.  */
3262   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3263   arg = fold_convert (arg_type, arg);
3264   result_type = gfc_get_int_type (gfc_default_integer_kind);
3265
3266   /* Compute LEADZ for the case i .ne. 0.  */
3267   s = TYPE_PRECISION (arg_type) - argsize;
3268   tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
3269   leadz = fold_build2 (MINUS_EXPR, result_type,
3270                        tmp, build_int_cst (result_type, s));
3271
3272   /* Build BIT_SIZE.  */
3273   bit_size = build_int_cst (result_type, argsize);
3274
3275   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3276                       arg, build_int_cst (arg_type, 0));
3277   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
3278 }
3279
3280 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3281
3282    The conditional expression is necessary because the result of TRAILZ(0)
3283    is defined, but the result of __builtin_ctz(0) is undefined for most
3284    targets.  */
3285  
3286 static void
3287 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3288 {
3289   tree arg;
3290   tree arg_type;
3291   tree cond;
3292   tree result_type;
3293   tree trailz;
3294   tree bit_size;
3295   tree func;
3296   int argsize;
3297
3298   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3299   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3300
3301   /* Which variant of __builtin_ctz* should we call?  */
3302   if (argsize <= INT_TYPE_SIZE)
3303     {
3304       arg_type = unsigned_type_node;
3305       func = built_in_decls[BUILT_IN_CTZ];
3306     }
3307   else if (argsize <= LONG_TYPE_SIZE)
3308     {
3309       arg_type = long_unsigned_type_node;
3310       func = built_in_decls[BUILT_IN_CTZL];
3311     }
3312   else if (argsize <= LONG_LONG_TYPE_SIZE)
3313     {
3314       arg_type = long_long_unsigned_type_node;
3315       func = built_in_decls[BUILT_IN_CTZLL];
3316     }
3317   else
3318     {
3319       gcc_assert (argsize == 128);
3320       arg_type = gfc_build_uint_type (argsize);
3321       func = gfor_fndecl_ctz128;
3322     }
3323
3324   /* Convert the actual argument twice: first, to the unsigned type of the
3325      same size; then, to the proper argument type for the built-in
3326      function.  But the return type is of the default INTEGER kind.  */
3327   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3328   arg = fold_convert (arg_type, arg);
3329   result_type = gfc_get_int_type (gfc_default_integer_kind);
3330
3331   /* Compute TRAILZ for the case i .ne. 0.  */
3332   trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3333                                                        func, 1, arg));
3334
3335   /* Build BIT_SIZE.  */
3336   bit_size = build_int_cst (result_type, argsize);
3337
3338   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3339                       arg, build_int_cst (arg_type, 0));
3340   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
3341 }
3342
3343 /* Process an intrinsic with unspecified argument-types that has an optional
3344    argument (which could be of type character), e.g. EOSHIFT.  For those, we
3345    need to append the string length of the optional argument if it is not
3346    present and the type is really character.
3347    primary specifies the position (starting at 1) of the non-optional argument
3348    specifying the type and optional gives the position of the optional
3349    argument in the arglist.  */
3350
3351 static void
3352 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3353                                      unsigned primary, unsigned optional)
3354 {
3355   gfc_actual_arglist* prim_arg;
3356   gfc_actual_arglist* opt_arg;
3357   unsigned cur_pos;
3358   gfc_actual_arglist* arg;
3359   gfc_symbol* sym;
3360   tree append_args;
3361
3362   /* Find the two arguments given as position.  */
3363   cur_pos = 0;
3364   prim_arg = NULL;
3365   opt_arg = NULL;
3366   for (arg = expr->value.function.actual; arg; arg = arg->next)
3367     {
3368       ++cur_pos;
3369
3370       if (cur_pos == primary)
3371         prim_arg = arg;
3372       if (cur_pos == optional)
3373         opt_arg = arg;
3374
3375       if (cur_pos >= primary && cur_pos >= optional)
3376         break;
3377     }
3378   gcc_assert (prim_arg);
3379   gcc_assert (prim_arg->expr);
3380   gcc_assert (opt_arg);
3381
3382   /* If we do have type CHARACTER and the optional argument is really absent,
3383      append a dummy 0 as string length.  */
3384   append_args = NULL_TREE;
3385   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3386     {
3387       tree dummy;
3388
3389       dummy = build_int_cst (gfc_charlen_type_node, 0);
3390       append_args = gfc_chainon_list (append_args, dummy);
3391     }
3392
3393   /* Build the call itself.  */
3394   sym = gfc_get_symbol_for_expr (expr);
3395   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3396                           append_args);
3397   gfc_free (sym);
3398 }
3399
3400
3401 /* The length of a character string.  */
3402 static void
3403 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3404 {
3405   tree len;
3406   tree type;
3407   tree decl;
3408   gfc_symbol *sym;
3409   gfc_se argse;
3410   gfc_expr *arg;
3411   gfc_ss *ss;
3412
3413   gcc_assert (!se->ss);
3414
3415   arg = expr->value.function.actual->expr;
3416
3417   type = gfc_typenode_for_spec (&expr->ts);
3418   switch (arg->expr_type)
3419     {
3420     case EXPR_CONSTANT:
3421       len = build_int_cst (NULL_TREE, arg->value.character.length);
3422       break;
3423
3424     case EXPR_ARRAY:
3425       /* Obtain the string length from the function used by
3426          trans-array.c(gfc_trans_array_constructor).  */
3427       len = NULL_TREE;
3428       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3429       break;
3430
3431     case EXPR_VARIABLE:
3432       if (arg->ref == NULL
3433             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3434         {
3435           /* This doesn't catch all cases.
3436              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3437              and the surrounding thread.  */
3438           sym = arg->symtree->n.sym;
3439           decl = gfc_get_symbol_decl (sym);
3440           if (decl == current_function_decl && sym->attr.function
3441                 && (sym->result == sym))
3442             decl = gfc_get_fake_result_decl (sym, 0);
3443
3444           len = sym->ts.u.cl->backend_decl;
3445           gcc_assert (len);
3446           break;
3447         }
3448
3449       /* Otherwise fall through.  */
3450
3451     default:
3452       /* Anybody stupid enough to do this deserves inefficient code.  */
3453       ss = gfc_walk_expr (arg);
3454       gfc_init_se (&argse, se);
3455       if (ss == gfc_ss_terminator)
3456         gfc_conv_expr (&argse, arg);
3457       else
3458         gfc_conv_expr_descriptor (&argse, arg, ss);
3459       gfc_add_block_to_block (&se->pre, &argse.pre);
3460       gfc_add_block_to_block (&se->post, &argse.post);
3461       len = argse.string_length;
3462       break;
3463     }
3464   se->expr = convert (type, len);
3465 }
3466
3467 /* The length of a character string not including trailing blanks.  */
3468 static void
3469 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3470 {
3471   int kind = expr->value.function.actual->expr->ts.kind;
3472   tree args[2], type, fndecl;
3473
3474   gfc_conv_intrinsic_function_args (se, expr, args, 2);