OSDN Git Service

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