OSDN Git Service

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