OSDN Git Service

PR fortran/50420
[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       ss = gfc_get_array_ss (gfc_ss_terminator, e, 0, GFC_SS_SECTION);
944
945       ref = e->ref;
946       while (ref)
947         {
948           if (ref->type == REF_ARRAY
949               && ref->u.ar.codimen > 0)
950             break;
951
952           ref = ref->next;
953         }
954
955       gcc_assert (ref != NULL);
956       ref->u.ar.type = AR_FULL;
957       ss->data.info.ref = ref;
958     }
959
960   return ss;
961 }
962
963
964 static void
965 trans_this_image (gfc_se * se, gfc_expr *expr)
966 {
967   stmtblock_t loop;
968   tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
969        lbound, ubound, extent, ml;
970   gfc_se argse;
971   gfc_ss *ss;
972   int rank, corank;
973
974   /* The case -fcoarray=single is handled elsewhere.  */
975   gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
976
977   gfc_init_coarray_decl (false);
978
979   /* Argument-free version: THIS_IMAGE().  */
980   if (expr->value.function.actual->expr == NULL)
981     {
982       se->expr = gfort_gvar_caf_this_image;
983       return;
984     }
985
986   /* Coarray-argument version: THIS_IMAGE(coarray [, dim]).  */
987
988   type = gfc_get_int_type (gfc_default_integer_kind);
989   corank = gfc_get_corank (expr->value.function.actual->expr);
990   rank = expr->value.function.actual->expr->rank;
991
992   /* Obtain the descriptor of the COARRAY.  */
993   gfc_init_se (&argse, NULL);
994   ss = walk_coarray (expr->value.function.actual->expr);
995   gcc_assert (ss != gfc_ss_terminator);
996   argse.want_coarray = 1;
997   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
998   gfc_add_block_to_block (&se->pre, &argse.pre);
999   gfc_add_block_to_block (&se->post, &argse.post);
1000   desc = argse.expr;
1001
1002   if (se->ss)
1003     {
1004       /* Create an implicit second parameter from the loop variable.  */
1005       gcc_assert (!expr->value.function.actual->next->expr);
1006       gcc_assert (corank > 0);
1007       gcc_assert (se->loop->dimen == 1);
1008       gcc_assert (se->ss->expr == expr);
1009
1010       dim_arg = se->loop->loopvar[0];
1011       dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1012                                  gfc_array_index_type, dim_arg,
1013                                  build_int_cst (TREE_TYPE (dim_arg), 1));
1014       gfc_advance_se_ss_chain (se);
1015     }
1016   else
1017     {
1018       /* Use the passed DIM= argument.  */
1019       gcc_assert (expr->value.function.actual->next->expr);
1020       gfc_init_se (&argse, NULL);
1021       gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1022                           gfc_array_index_type);
1023       gfc_add_block_to_block (&se->pre, &argse.pre);
1024       dim_arg = argse.expr;
1025
1026       if (INTEGER_CST_P (dim_arg))
1027         {
1028           int hi, co_dim;
1029
1030           hi = TREE_INT_CST_HIGH (dim_arg);
1031           co_dim = TREE_INT_CST_LOW (dim_arg);
1032           if (hi || co_dim < 1
1033               || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1034             gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1035                        "dimension index", expr->value.function.isym->name,
1036                        &expr->where);
1037         }
1038      else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1039         {
1040           dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1041           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1042                                   dim_arg,
1043                                   build_int_cst (TREE_TYPE (dim_arg), 1));
1044           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1045           tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1046                                  dim_arg, tmp);
1047           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1048                                   boolean_type_node, cond, tmp);
1049           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1050                                    gfc_msg_fault);
1051         }
1052     }
1053
1054   /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1055      one always has a dim_arg argument.
1056
1057      m = this_images() - 1
1058      i = rank
1059      min_var = min (rank + corank - 2, rank + dim_arg - 1)
1060      for (;;)
1061        {
1062          extent = gfc_extent(i)
1063          ml = m
1064          m  = m/extent
1065          if (i >= min_var) 
1066            goto exit_label
1067          i++
1068        }
1069      exit_label:
1070      sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1071                                        : m + lcobound(corank)
1072   */
1073
1074   m = gfc_create_var (type, NULL); 
1075   ml = gfc_create_var (type, NULL); 
1076   loop_var = gfc_create_var (integer_type_node, NULL); 
1077   min_var = gfc_create_var (integer_type_node, NULL); 
1078
1079   /* m = this_image () - 1.  */
1080   tmp = fold_convert (type, gfort_gvar_caf_this_image);
1081   tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
1082                        build_int_cst (type, 1));
1083   gfc_add_modify (&se->pre, m, tmp);
1084
1085   /* min_var = min (rank + corank-2, rank + dim_arg - 1).  */
1086   tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1087                          fold_convert (integer_type_node, dim_arg),
1088                          build_int_cst (integer_type_node, rank - 1));
1089   tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1090                          build_int_cst (integer_type_node, rank + corank - 2),
1091                          tmp);
1092   gfc_add_modify (&se->pre, min_var, tmp);
1093
1094   /* i = rank.  */
1095   tmp = build_int_cst (integer_type_node, rank);
1096   gfc_add_modify (&se->pre, loop_var, tmp);
1097
1098   exit_label = gfc_build_label_decl (NULL_TREE);
1099   TREE_USED (exit_label) = 1;
1100
1101   /* Loop body.  */
1102   gfc_init_block (&loop);
1103
1104   /* ml = m.  */
1105   gfc_add_modify (&loop, ml, m);
1106
1107   /* extent = ...  */
1108   lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1109   ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1110   extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1111   extent = fold_convert (type, extent);
1112
1113   /* m = m/extent.  */
1114   gfc_add_modify (&loop, m, 
1115                   fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
1116                           m, extent));
1117
1118   /* Exit condition:  if (i >= min_var) goto exit_label.  */
1119   cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
1120                   min_var);
1121   tmp = build1_v (GOTO_EXPR, exit_label);
1122   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1123                          build_empty_stmt (input_location));
1124   gfc_add_expr_to_block (&loop, tmp);
1125
1126   /* Increment loop variable: i++.  */
1127   gfc_add_modify (&loop, loop_var,
1128                   fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1129                                    loop_var,
1130                                    build_int_cst (integer_type_node, 1)));
1131
1132   /* Making the loop... actually loop!  */
1133   tmp = gfc_finish_block (&loop);
1134   tmp = build1_v (LOOP_EXPR, tmp);
1135   gfc_add_expr_to_block (&se->pre, tmp);
1136
1137   /* The exit label.  */
1138   tmp = build1_v (LABEL_EXPR, exit_label);
1139   gfc_add_expr_to_block (&se->pre, tmp);
1140
1141   /*  sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1142                                       : m + lcobound(corank) */
1143
1144   cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
1145                           build_int_cst (TREE_TYPE (dim_arg), corank));
1146
1147   lbound = gfc_conv_descriptor_lbound_get (desc,
1148                 fold_build2_loc (input_location, PLUS_EXPR,
1149                                  gfc_array_index_type, dim_arg,
1150                                  build_int_cst (TREE_TYPE (dim_arg), rank-1)));
1151   lbound = fold_convert (type, lbound);
1152
1153   tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
1154                          fold_build2_loc (input_location, MULT_EXPR, type,
1155                                           m, extent));
1156   tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1157
1158   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
1159                               fold_build2_loc (input_location, PLUS_EXPR, type,
1160                                                m, lbound));
1161 }
1162
1163
1164 static void
1165 trans_image_index (gfc_se * se, gfc_expr *expr)
1166 {
1167   tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
1168        tmp, invalid_bound;
1169   gfc_se argse, subse;
1170   gfc_ss *ss, *subss;
1171   int rank, corank, codim;
1172
1173   type = gfc_get_int_type (gfc_default_integer_kind);
1174   corank = gfc_get_corank (expr->value.function.actual->expr);
1175   rank = expr->value.function.actual->expr->rank;
1176
1177   /* Obtain the descriptor of the COARRAY.  */
1178   gfc_init_se (&argse, NULL);
1179   ss = walk_coarray (expr->value.function.actual->expr);
1180   gcc_assert (ss != gfc_ss_terminator);
1181   argse.want_coarray = 1;
1182   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
1183   gfc_add_block_to_block (&se->pre, &argse.pre);
1184   gfc_add_block_to_block (&se->post, &argse.post);
1185   desc = argse.expr;
1186
1187   /* Obtain a handle to the SUB argument.  */
1188   gfc_init_se (&subse, NULL);
1189   subss = gfc_walk_expr (expr->value.function.actual->next->expr);
1190   gcc_assert (subss != gfc_ss_terminator);
1191   gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
1192                             subss);
1193   gfc_add_block_to_block (&se->pre, &subse.pre);
1194   gfc_add_block_to_block (&se->post, &subse.post);
1195   subdesc = build_fold_indirect_ref_loc (input_location,
1196                         gfc_conv_descriptor_data_get (subse.expr));
1197
1198   /* Fortran 2008 does not require that the values remain in the cobounds,
1199      thus we need explicitly check this - and return 0 if they are exceeded.  */
1200
1201   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1202   tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
1203   invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1204                                  fold_convert (gfc_array_index_type, tmp),
1205                                  lbound);
1206
1207   for (codim = corank + rank - 2; codim >= rank; codim--)
1208     {
1209       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1210       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1211       tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1212       cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1213                               fold_convert (gfc_array_index_type, tmp),
1214                               lbound);
1215       invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1216                                        boolean_type_node, invalid_bound, cond);
1217       cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1218                               fold_convert (gfc_array_index_type, tmp),
1219                               ubound);
1220       invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1221                                        boolean_type_node, invalid_bound, cond);
1222     }
1223
1224   invalid_bound = gfc_unlikely (invalid_bound);
1225
1226
1227   /* See Fortran 2008, C.10 for the following algorithm.  */
1228
1229   /* coindex = sub(corank) - lcobound(n).  */
1230   coindex = fold_convert (gfc_array_index_type,
1231                           gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
1232                                                NULL));
1233   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1234   coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1235                              fold_convert (gfc_array_index_type, coindex),
1236                              lbound);
1237
1238   for (codim = corank + rank - 2; codim >= rank; codim--)
1239     {
1240       tree extent, ubound;
1241
1242       /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim).  */
1243       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1244       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1245       extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1246
1247       /* coindex *= extent.  */
1248       coindex = fold_build2_loc (input_location, MULT_EXPR,
1249                                  gfc_array_index_type, coindex, extent);
1250
1251       /* coindex += sub(codim).  */
1252       tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1253       coindex = fold_build2_loc (input_location, PLUS_EXPR,
1254                                  gfc_array_index_type, coindex,
1255                                  fold_convert (gfc_array_index_type, tmp));
1256
1257       /* coindex -= lbound(codim).  */
1258       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1259       coindex = fold_build2_loc (input_location, MINUS_EXPR,
1260                                  gfc_array_index_type, coindex, lbound);
1261     }
1262
1263   coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
1264                              fold_convert(type, coindex),
1265                              build_int_cst (type, 1));
1266
1267   /* Return 0 if "coindex" exceeds num_images().  */
1268
1269   if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
1270     num_images = build_int_cst (type, 1);
1271   else
1272     {
1273       gfc_init_coarray_decl (false);
1274       num_images = gfort_gvar_caf_num_images;
1275     }
1276
1277   tmp = gfc_create_var (type, NULL);
1278   gfc_add_modify (&se->pre, tmp, coindex);
1279
1280   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1281                           num_images);
1282   cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
1283                           cond,
1284                           fold_convert (boolean_type_node, invalid_bound));
1285   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
1286                               build_int_cst (type, 0), tmp);
1287 }
1288
1289
1290 static void
1291 trans_num_images (gfc_se * se)
1292 {
1293   gfc_init_coarray_decl (false);
1294   se->expr = gfort_gvar_caf_num_images;
1295 }
1296
1297
1298 /* Evaluate a single upper or lower bound.  */
1299 /* TODO: bound intrinsic generates way too much unnecessary code.  */
1300
1301 static void
1302 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
1303 {
1304   gfc_actual_arglist *arg;
1305   gfc_actual_arglist *arg2;
1306   tree desc;
1307   tree type;
1308   tree bound;
1309   tree tmp;
1310   tree cond, cond1, cond3, cond4, size;
1311   tree ubound;
1312   tree lbound;
1313   gfc_se argse;
1314   gfc_ss *ss;
1315   gfc_array_spec * as;
1316
1317   arg = expr->value.function.actual;
1318   arg2 = arg->next;
1319
1320   if (se->ss)
1321     {
1322       /* Create an implicit second parameter from the loop variable.  */
1323       gcc_assert (!arg2->expr);
1324       gcc_assert (se->loop->dimen == 1);
1325       gcc_assert (se->ss->expr == expr);
1326       gfc_advance_se_ss_chain (se);
1327       bound = se->loop->loopvar[0];
1328       bound = fold_build2_loc (input_location, MINUS_EXPR,
1329                                gfc_array_index_type, bound,
1330                                se->loop->from[0]);
1331     }
1332   else
1333     {
1334       /* use the passed argument.  */
1335       gcc_assert (arg2->expr);
1336       gfc_init_se (&argse, NULL);
1337       gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1338       gfc_add_block_to_block (&se->pre, &argse.pre);
1339       bound = argse.expr;
1340       /* Convert from one based to zero based.  */
1341       bound = fold_build2_loc (input_location, MINUS_EXPR,
1342                                gfc_array_index_type, bound,
1343                                gfc_index_one_node);
1344     }
1345
1346   /* TODO: don't re-evaluate the descriptor on each iteration.  */
1347   /* Get a descriptor for the first parameter.  */
1348   ss = gfc_walk_expr (arg->expr);
1349   gcc_assert (ss != gfc_ss_terminator);
1350   gfc_init_se (&argse, NULL);
1351   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1352   gfc_add_block_to_block (&se->pre, &argse.pre);
1353   gfc_add_block_to_block (&se->post, &argse.post);
1354
1355   desc = argse.expr;
1356
1357   if (INTEGER_CST_P (bound))
1358     {
1359       int hi, low;
1360
1361       hi = TREE_INT_CST_HIGH (bound);
1362       low = TREE_INT_CST_LOW (bound);
1363       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
1364         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1365                    "dimension index", upper ? "UBOUND" : "LBOUND",
1366                    &expr->where);
1367     }
1368   else
1369     {
1370       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1371         {
1372           bound = gfc_evaluate_now (bound, &se->pre);
1373           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1374                                   bound, build_int_cst (TREE_TYPE (bound), 0));
1375           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
1376           tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1377                                  bound, tmp);
1378           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1379                                   boolean_type_node, cond, tmp);
1380           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1381                                    gfc_msg_fault);
1382         }
1383     }
1384
1385   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
1386   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
1387   
1388   as = gfc_get_full_arrayspec_from_expr (arg->expr);
1389
1390   /* 13.14.53: Result value for LBOUND
1391
1392      Case (i): For an array section or for an array expression other than a
1393                whole array or array structure component, LBOUND(ARRAY, DIM)
1394                has the value 1.  For a whole array or array structure
1395                component, LBOUND(ARRAY, DIM) has the value:
1396                  (a) equal to the lower bound for subscript DIM of ARRAY if
1397                      dimension DIM of ARRAY does not have extent zero
1398                      or if ARRAY is an assumed-size array of rank DIM,
1399               or (b) 1 otherwise.
1400
1401      13.14.113: Result value for UBOUND
1402
1403      Case (i): For an array section or for an array expression other than a
1404                whole array or array structure component, UBOUND(ARRAY, DIM)
1405                has the value equal to the number of elements in the given
1406                dimension; otherwise, it has a value equal to the upper bound
1407                for subscript DIM of ARRAY if dimension DIM of ARRAY does
1408                not have size zero and has value zero if dimension DIM has
1409                size zero.  */
1410
1411   if (as)
1412     {
1413       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
1414
1415       cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1416                                ubound, lbound);
1417       cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1418                                stride, gfc_index_zero_node);
1419       cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1420                                boolean_type_node, cond3, cond1);
1421       cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1422                                stride, gfc_index_zero_node);
1423
1424       if (upper)
1425         {
1426           tree cond5;
1427           cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1428                                   boolean_type_node, cond3, cond4);
1429           cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1430                                    gfc_index_one_node, lbound);
1431           cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1432                                    boolean_type_node, cond4, cond5);
1433
1434           cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1435                                   boolean_type_node, cond, cond5);
1436
1437           se->expr = fold_build3_loc (input_location, COND_EXPR,
1438                                       gfc_array_index_type, cond,
1439                                       ubound, gfc_index_zero_node);
1440         }
1441       else
1442         {
1443           if (as->type == AS_ASSUMED_SIZE)
1444             cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1445                                     bound, build_int_cst (TREE_TYPE (bound),
1446                                                           arg->expr->rank - 1));
1447           else
1448             cond = boolean_false_node;
1449
1450           cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1451                                    boolean_type_node, cond3, cond4);
1452           cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1453                                   boolean_type_node, cond, cond1);
1454
1455           se->expr = fold_build3_loc (input_location, COND_EXPR,
1456                                       gfc_array_index_type, cond,
1457                                       lbound, gfc_index_one_node);
1458         }
1459     }
1460   else
1461     {
1462       if (upper)
1463         {
1464           size = fold_build2_loc (input_location, MINUS_EXPR,
1465                                   gfc_array_index_type, ubound, lbound);
1466           se->expr = fold_build2_loc (input_location, PLUS_EXPR,
1467                                       gfc_array_index_type, size,
1468                                   gfc_index_one_node);
1469           se->expr = fold_build2_loc (input_location, MAX_EXPR,
1470                                       gfc_array_index_type, se->expr,
1471                                       gfc_index_zero_node);
1472         }
1473       else
1474         se->expr = gfc_index_one_node;
1475     }
1476
1477   type = gfc_typenode_for_spec (&expr->ts);
1478   se->expr = convert (type, se->expr);
1479 }
1480
1481
1482 static void
1483 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
1484 {
1485   gfc_actual_arglist *arg;
1486   gfc_actual_arglist *arg2;
1487   gfc_se argse;
1488   gfc_ss *ss;
1489   tree bound, resbound, resbound2, desc, cond, tmp;
1490   tree type;
1491   int corank;
1492
1493   gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
1494               || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
1495               || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
1496
1497   arg = expr->value.function.actual;
1498   arg2 = arg->next;
1499
1500   gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
1501   corank = gfc_get_corank (arg->expr);
1502
1503   ss = walk_coarray (arg->expr);
1504   gcc_assert (ss != gfc_ss_terminator);
1505   gfc_init_se (&argse, NULL);
1506   argse.want_coarray = 1;
1507
1508   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1509   gfc_add_block_to_block (&se->pre, &argse.pre);
1510   gfc_add_block_to_block (&se->post, &argse.post);
1511   desc = argse.expr;
1512
1513   if (se->ss)
1514     {
1515       /* Create an implicit second parameter from the loop variable.  */
1516       gcc_assert (!arg2->expr);
1517       gcc_assert (corank > 0);
1518       gcc_assert (se->loop->dimen == 1);
1519       gcc_assert (se->ss->expr == expr);
1520
1521       bound = se->loop->loopvar[0];
1522       bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1523                                bound, gfc_rank_cst[arg->expr->rank]);
1524       gfc_advance_se_ss_chain (se);
1525     }
1526   else
1527     {
1528       /* use the passed argument.  */
1529       gcc_assert (arg2->expr);
1530       gfc_init_se (&argse, NULL);
1531       gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1532       gfc_add_block_to_block (&se->pre, &argse.pre);
1533       bound = argse.expr;
1534
1535       if (INTEGER_CST_P (bound))
1536         {
1537           int hi, low;
1538
1539           hi = TREE_INT_CST_HIGH (bound);
1540           low = TREE_INT_CST_LOW (bound);
1541           if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1542             gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1543                        "dimension index", expr->value.function.isym->name,
1544                        &expr->where);
1545         }
1546       else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1547         {
1548           bound = gfc_evaluate_now (bound, &se->pre);
1549           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1550                                   bound, build_int_cst (TREE_TYPE (bound), 1));
1551           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1552           tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1553                                  bound, tmp);
1554           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1555                                   boolean_type_node, cond, tmp);
1556           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1557                                    gfc_msg_fault);
1558         }
1559
1560
1561       /* Substract 1 to get to zero based and add dimensions.  */
1562       switch (arg->expr->rank)
1563         {
1564         case 0:
1565           bound = fold_build2_loc (input_location, MINUS_EXPR,
1566                                    gfc_array_index_type, bound,
1567                                    gfc_index_one_node);
1568         case 1:
1569           break;
1570         default:
1571           bound = fold_build2_loc (input_location, PLUS_EXPR,
1572                                    gfc_array_index_type, bound,
1573                                    gfc_rank_cst[arg->expr->rank - 1]);
1574         }
1575     }
1576
1577   resbound = gfc_conv_descriptor_lbound_get (desc, bound);
1578
1579   /* Handle UCOBOUND with special handling of the last codimension.  */
1580   if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
1581     {
1582       /* Last codimension: For -fcoarray=single just return
1583          the lcobound - otherwise add
1584            ceiling (real (num_images ()) / real (size)) - 1
1585          = (num_images () + size - 1) / size - 1
1586          = (num_images - 1) / size(),
1587          where size is the product of the extent of all but the last
1588          codimension.  */
1589
1590       if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
1591         {
1592           tree cosize;
1593
1594           gfc_init_coarray_decl (false);
1595           cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
1596
1597           tmp = fold_build2_loc (input_location, MINUS_EXPR,
1598                                  gfc_array_index_type,
1599                                  gfort_gvar_caf_num_images,
1600                                  build_int_cst (gfc_array_index_type, 1));
1601           tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1602                                  gfc_array_index_type, tmp,
1603                                  fold_convert (gfc_array_index_type, cosize));
1604           resbound = fold_build2_loc (input_location, PLUS_EXPR,
1605                                       gfc_array_index_type, resbound, tmp);
1606         }
1607       else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
1608         {
1609           /* ubound = lbound + num_images() - 1.  */
1610           gfc_init_coarray_decl (false);
1611           tmp = fold_build2_loc (input_location, MINUS_EXPR,
1612                                  gfc_array_index_type,
1613                                  gfort_gvar_caf_num_images,
1614                                  build_int_cst (gfc_array_index_type, 1));
1615           resbound = fold_build2_loc (input_location, PLUS_EXPR,
1616                                       gfc_array_index_type, resbound, tmp);
1617         }
1618
1619       if (corank > 1)
1620         {
1621           cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1622                                   bound,
1623                                   build_int_cst (TREE_TYPE (bound),
1624                                                  arg->expr->rank + corank - 1));
1625
1626           resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
1627           se->expr = fold_build3_loc (input_location, COND_EXPR,
1628                                       gfc_array_index_type, cond,
1629                                       resbound, resbound2);
1630         }
1631       else
1632         se->expr = resbound;
1633     }
1634   else
1635     se->expr = resbound;
1636
1637   type = gfc_typenode_for_spec (&expr->ts);
1638   se->expr = convert (type, se->expr);
1639 }
1640
1641
1642 static void
1643 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1644 {
1645   tree arg, cabs;
1646
1647   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1648
1649   switch (expr->value.function.actual->expr->ts.type)
1650     {
1651     case BT_INTEGER:
1652     case BT_REAL:
1653       se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
1654                                   arg);
1655       break;
1656
1657     case BT_COMPLEX:
1658       cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
1659       se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
1660       break;
1661
1662     default:
1663       gcc_unreachable ();
1664     }
1665 }
1666
1667
1668 /* Create a complex value from one or two real components.  */
1669
1670 static void
1671 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1672 {
1673   tree real;
1674   tree imag;
1675   tree type;
1676   tree *args;
1677   unsigned int num_args;
1678
1679   num_args = gfc_intrinsic_argument_list_length (expr);
1680   args = XALLOCAVEC (tree, num_args);
1681
1682   type = gfc_typenode_for_spec (&expr->ts);
1683   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1684   real = convert (TREE_TYPE (type), args[0]);
1685   if (both)
1686     imag = convert (TREE_TYPE (type), args[1]);
1687   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1688     {
1689       imag = fold_build1_loc (input_location, IMAGPART_EXPR,
1690                               TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1691       imag = convert (TREE_TYPE (type), imag);
1692     }
1693   else
1694     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1695
1696   se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
1697 }
1698
1699 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1700                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1701 /* TODO: MOD(x, 0)  */
1702
1703 static void
1704 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1705 {
1706   tree type;
1707   tree itype;
1708   tree tmp;
1709   tree test;
1710   tree test2;
1711   tree fmod;
1712   mpfr_t huge;
1713   int n, ikind;
1714   tree args[2];
1715
1716   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1717
1718   switch (expr->ts.type)
1719     {
1720     case BT_INTEGER:
1721       /* Integer case is easy, we've got a builtin op.  */
1722       type = TREE_TYPE (args[0]);
1723
1724       if (modulo)
1725        se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
1726                                    args[0], args[1]);
1727       else
1728        se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
1729                                    args[0], args[1]);
1730       break;
1731
1732     case BT_REAL:
1733       fmod = NULL_TREE;
1734       /* Check if we have a builtin fmod.  */
1735       fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1736
1737       /* Use it if it exists.  */
1738       if (fmod != NULL_TREE)
1739         {
1740           tmp = build_addr (fmod, current_function_decl);
1741           se->expr = build_call_array_loc (input_location,
1742                                        TREE_TYPE (TREE_TYPE (fmod)),
1743                                        tmp, 2, args);
1744           if (modulo == 0)
1745             return;
1746         }
1747
1748       type = TREE_TYPE (args[0]);
1749
1750       args[0] = gfc_evaluate_now (args[0], &se->pre);
1751       args[1] = gfc_evaluate_now (args[1], &se->pre);
1752
1753       /* Definition:
1754          modulo = arg - floor (arg/arg2) * arg2, so
1755                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, 
1756          where
1757           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1758          thereby avoiding another division and retaining the accuracy
1759          of the builtin function.  */
1760       if (fmod != NULL_TREE && modulo)
1761         {
1762           tree zero = gfc_build_const (type, integer_zero_node);
1763           tmp = gfc_evaluate_now (se->expr, &se->pre);
1764           test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1765                                   args[0], zero);
1766           test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1767                                    args[1], zero);
1768           test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
1769                                    boolean_type_node, test, test2);
1770           test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1771                                   tmp, zero);
1772           test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1773                                   boolean_type_node, test, test2);
1774           test = gfc_evaluate_now (test, &se->pre);
1775           se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
1776                                   fold_build2_loc (input_location, PLUS_EXPR,
1777                                                    type, tmp, args[1]), tmp);
1778           return;
1779         }
1780
1781       /* If we do not have a built_in fmod, the calculation is going to
1782          have to be done longhand.  */
1783       tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
1784
1785       /* Test if the value is too large to handle sensibly.  */
1786       gfc_set_model_kind (expr->ts.kind);
1787       mpfr_init (huge);
1788       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1789       ikind = expr->ts.kind;
1790       if (n < 0)
1791         {
1792           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1793           ikind = gfc_max_integer_kind;
1794         }
1795       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1796       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1797       test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1798                                tmp, test);
1799
1800       mpfr_neg (huge, huge, GFC_RND_MODE);
1801       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1802       test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1803                               test);
1804       test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1805                                boolean_type_node, test, test2);
1806
1807       itype = gfc_get_int_type (ikind);
1808       if (modulo)
1809        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1810       else
1811        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1812       tmp = convert (type, tmp);
1813       tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
1814                              args[0]);
1815       tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
1816       se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
1817                                   tmp);
1818       mpfr_clear (huge);
1819       break;
1820
1821     default:
1822       gcc_unreachable ();
1823     }
1824 }
1825
1826 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1827    DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1828    where the right shifts are logical (i.e. 0's are shifted in).
1829    Because SHIFT_EXPR's want shifts strictly smaller than the integral
1830    type width, we have to special-case both S == 0 and S == BITSIZE(J):
1831      DSHIFTL(I,J,0) = I
1832      DSHIFTL(I,J,BITSIZE) = J
1833      DSHIFTR(I,J,0) = J
1834      DSHIFTR(I,J,BITSIZE) = I.  */
1835
1836 static void
1837 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
1838 {
1839   tree type, utype, stype, arg1, arg2, shift, res, left, right;
1840   tree args[3], cond, tmp;
1841   int bitsize;
1842
1843   gfc_conv_intrinsic_function_args (se, expr, args, 3);
1844
1845   gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
1846   type = TREE_TYPE (args[0]);
1847   bitsize = TYPE_PRECISION (type);
1848   utype = unsigned_type_for (type);
1849   stype = TREE_TYPE (args[2]);
1850
1851   arg1 = gfc_evaluate_now (args[0], &se->pre);
1852   arg2 = gfc_evaluate_now (args[1], &se->pre);
1853   shift = gfc_evaluate_now (args[2], &se->pre);
1854
1855   /* The generic case.  */
1856   tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
1857                          build_int_cst (stype, bitsize), shift);
1858   left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
1859                           arg1, dshiftl ? shift : tmp);
1860
1861   right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
1862                            fold_convert (utype, arg2), dshiftl ? tmp : shift);
1863   right = fold_convert (type, right);
1864
1865   res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
1866
1867   /* Special cases.  */
1868   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1869                           build_int_cst (stype, 0));
1870   res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1871                          dshiftl ? arg1 : arg2, res);
1872
1873   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1874                           build_int_cst (stype, bitsize));
1875   res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1876                          dshiftl ? arg2 : arg1, res);
1877
1878   se->expr = res;
1879 }
1880
1881
1882 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1883
1884 static void
1885 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1886 {
1887   tree val;
1888   tree tmp;
1889   tree type;
1890   tree zero;
1891   tree args[2];
1892
1893   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1894   type = TREE_TYPE (args[0]);
1895
1896   val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
1897   val = gfc_evaluate_now (val, &se->pre);
1898
1899   zero = gfc_build_const (type, integer_zero_node);
1900   tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
1901   se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
1902 }
1903
1904
1905 /* SIGN(A, B) is absolute value of A times sign of B.
1906    The real value versions use library functions to ensure the correct
1907    handling of negative zero.  Integer case implemented as:
1908    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1909   */
1910
1911 static void
1912 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1913 {
1914   tree tmp;
1915   tree type;
1916   tree args[2];
1917
1918   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1919   if (expr->ts.type == BT_REAL)
1920     {
1921       tree abs;
1922
1923       tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1924       abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1925
1926       /* We explicitly have to ignore the minus sign. We do so by using
1927          result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
1928       if (!gfc_option.flag_sign_zero
1929           && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1930         {
1931           tree cond, zero;
1932           zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1933           cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1934                                   args[1], zero);
1935           se->expr = fold_build3_loc (input_location, COND_EXPR,
1936                                   TREE_TYPE (args[0]), cond,
1937                                   build_call_expr_loc (input_location, abs, 1,
1938                                                        args[0]),
1939                                   build_call_expr_loc (input_location, tmp, 2,
1940                                                        args[0], args[1]));
1941         }
1942       else
1943         se->expr = build_call_expr_loc (input_location, tmp, 2,
1944                                         args[0], args[1]);
1945       return;
1946     }
1947
1948   /* Having excluded floating point types, we know we are now dealing
1949      with signed integer types.  */
1950   type = TREE_TYPE (args[0]);
1951
1952   /* Args[0] is used multiple times below.  */
1953   args[0] = gfc_evaluate_now (args[0], &se->pre);
1954
1955   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1956      the signs of A and B are the same, and of all ones if they differ.  */
1957   tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
1958   tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
1959                          build_int_cst (type, TYPE_PRECISION (type) - 1));
1960   tmp = gfc_evaluate_now (tmp, &se->pre);
1961
1962   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1963      is all ones (i.e. -1).  */
1964   se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
1965                               fold_build2_loc (input_location, PLUS_EXPR,
1966                                                type, args[0], tmp), tmp);
1967 }
1968
1969
1970 /* Test for the presence of an optional argument.  */
1971
1972 static void
1973 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1974 {
1975   gfc_expr *arg;
1976
1977   arg = expr->value.function.actual->expr;
1978   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1979   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1980   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1981 }
1982
1983
1984 /* Calculate the double precision product of two single precision values.  */
1985
1986 static void
1987 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1988 {
1989   tree type;
1990   tree args[2];
1991
1992   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1993
1994   /* Convert the args to double precision before multiplying.  */
1995   type = gfc_typenode_for_spec (&expr->ts);
1996   args[0] = convert (type, args[0]);
1997   args[1] = convert (type, args[1]);
1998   se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
1999                               args[1]);
2000 }
2001
2002
2003 /* Return a length one character string containing an ascii character.  */
2004
2005 static void
2006 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
2007 {
2008   tree arg[2];
2009   tree var;
2010   tree type;
2011   unsigned int num_args;
2012
2013   num_args = gfc_intrinsic_argument_list_length (expr);
2014   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
2015
2016   type = gfc_get_char_type (expr->ts.kind);
2017   var = gfc_create_var (type, "char");
2018
2019   arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
2020   gfc_add_modify (&se->pre, var, arg[0]);
2021   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
2022   se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2023 }
2024
2025
2026 static void
2027 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
2028 {
2029   tree var;
2030   tree len;
2031   tree tmp;
2032   tree cond;
2033   tree fndecl;
2034   tree *args;
2035   unsigned int num_args;
2036
2037   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2038   args = XALLOCAVEC (tree, num_args);
2039
2040   var = gfc_create_var (pchar_type_node, "pstr");
2041   len = gfc_create_var (gfc_charlen_type_node, "len");
2042
2043   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2044   args[0] = gfc_build_addr_expr (NULL_TREE, var);
2045   args[1] = gfc_build_addr_expr (NULL_TREE, len);
2046
2047   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
2048   tmp = build_call_array_loc (input_location,
2049                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
2050                           fndecl, num_args, args);
2051   gfc_add_expr_to_block (&se->pre, tmp);
2052
2053   /* Free the temporary afterwards, if necessary.  */
2054   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2055                           len, build_int_cst (TREE_TYPE (len), 0));
2056   tmp = gfc_call_free (var);
2057   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2058   gfc_add_expr_to_block (&se->post, tmp);
2059
2060   se->expr = var;
2061   se->string_length = len;
2062 }
2063
2064
2065 static void
2066 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
2067 {
2068   tree var;
2069   tree len;
2070   tree tmp;
2071   tree cond;
2072   tree fndecl;
2073   tree *args;
2074   unsigned int num_args;
2075
2076   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2077   args = XALLOCAVEC (tree, num_args);
2078
2079   var = gfc_create_var (pchar_type_node, "pstr");
2080   len = gfc_create_var (gfc_charlen_type_node, "len");
2081
2082   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2083   args[0] = gfc_build_addr_expr (NULL_TREE, var);
2084   args[1] = gfc_build_addr_expr (NULL_TREE, len);
2085
2086   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
2087   tmp = build_call_array_loc (input_location,
2088                           TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
2089                           fndecl, num_args, args);
2090   gfc_add_expr_to_block (&se->pre, tmp);
2091
2092   /* Free the temporary afterwards, if necessary.  */
2093   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2094                           len, build_int_cst (TREE_TYPE (len), 0));
2095   tmp = gfc_call_free (var);
2096   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2097   gfc_add_expr_to_block (&se->post, tmp);
2098
2099   se->expr = var;
2100   se->string_length = len;
2101 }
2102
2103
2104 /* Return a character string containing the tty name.  */
2105
2106 static void
2107 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
2108 {
2109   tree var;
2110   tree len;
2111   tree tmp;
2112   tree cond;
2113   tree fndecl;
2114   tree *args;
2115   unsigned int num_args;
2116
2117   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2118   args = XALLOCAVEC (tree, num_args);
2119
2120   var = gfc_create_var (pchar_type_node, "pstr");
2121   len = gfc_create_var (gfc_charlen_type_node, "len");
2122
2123   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2124   args[0] = gfc_build_addr_expr (NULL_TREE, var);
2125   args[1] = gfc_build_addr_expr (NULL_TREE, len);
2126
2127   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
2128   tmp = build_call_array_loc (input_location,
2129                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
2130                           fndecl, num_args, args);
2131   gfc_add_expr_to_block (&se->pre, tmp);
2132
2133   /* Free the temporary afterwards, if necessary.  */
2134   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2135                           len, build_int_cst (TREE_TYPE (len), 0));
2136   tmp = gfc_call_free (var);
2137   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2138   gfc_add_expr_to_block (&se->post, tmp);
2139
2140   se->expr = var;
2141   se->string_length = len;
2142 }
2143
2144
2145 /* Get the minimum/maximum value of all the parameters.
2146     minmax (a1, a2, a3, ...)
2147     {
2148       mvar = a1;
2149       if (a2 .op. mvar || isnan(mvar))
2150         mvar = a2;
2151       if (a3 .op. mvar || isnan(mvar))
2152         mvar = a3;
2153       ...
2154       return mvar
2155     }
2156  */
2157
2158 /* TODO: Mismatching types can occur when specific names are used.
2159    These should be handled during resolution.  */
2160 static void
2161 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
2162 {
2163   tree tmp;
2164   tree mvar;
2165   tree val;
2166   tree thencase;
2167   tree *args;
2168   tree type;
2169   gfc_actual_arglist *argexpr;
2170   unsigned int i, nargs;
2171
2172   nargs = gfc_intrinsic_argument_list_length (expr);
2173   args = XALLOCAVEC (tree, nargs);
2174
2175   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
2176   type = gfc_typenode_for_spec (&expr->ts);
2177
2178   argexpr = expr->value.function.actual;
2179   if (TREE_TYPE (args[0]) != type)
2180     args[0] = convert (type, args[0]);
2181   /* Only evaluate the argument once.  */
2182   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
2183     args[0] = gfc_evaluate_now (args[0], &se->pre);
2184
2185   mvar = gfc_create_var (type, "M");
2186   gfc_add_modify (&se->pre, mvar, args[0]);
2187   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
2188     {
2189       tree cond, isnan;
2190
2191       val = args[i]; 
2192
2193       /* Handle absent optional arguments by ignoring the comparison.  */
2194       if (argexpr->expr->expr_type == EXPR_VARIABLE
2195           && argexpr->expr->symtree->n.sym->attr.optional
2196           && TREE_CODE (val) == INDIRECT_REF)
2197         cond = fold_build2_loc (input_location,
2198                                 NE_EXPR, boolean_type_node,
2199                                 TREE_OPERAND (val, 0), 
2200                         build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
2201       else
2202       {
2203         cond = NULL_TREE;
2204
2205         /* Only evaluate the argument once.  */
2206         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
2207           val = gfc_evaluate_now (val, &se->pre);
2208       }
2209
2210       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
2211
2212       tmp = fold_build2_loc (input_location, op, boolean_type_node,
2213                              convert (type, val), mvar);
2214
2215       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2216          __builtin_isnan might be made dependent on that module being loaded,
2217          to help performance of programs that don't rely on IEEE semantics.  */
2218       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
2219         {
2220           isnan = build_call_expr_loc (input_location,
2221                                        builtin_decl_explicit (BUILT_IN_ISNAN),
2222                                        1, mvar);
2223           tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2224                                  boolean_type_node, tmp,
2225                                  fold_convert (boolean_type_node, isnan));
2226         }
2227       tmp = build3_v (COND_EXPR, tmp, thencase,
2228                       build_empty_stmt (input_location));
2229
2230       if (cond != NULL_TREE)
2231         tmp = build3_v (COND_EXPR, cond, tmp,
2232                         build_empty_stmt (input_location));
2233
2234       gfc_add_expr_to_block (&se->pre, tmp);
2235       argexpr = argexpr->next;
2236     }
2237   se->expr = mvar;
2238 }
2239
2240
2241 /* Generate library calls for MIN and MAX intrinsics for character
2242    variables.  */
2243 static void
2244 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
2245 {
2246   tree *args;
2247   tree var, len, fndecl, tmp, cond, function;
2248   unsigned int nargs;
2249
2250   nargs = gfc_intrinsic_argument_list_length (expr);
2251   args = XALLOCAVEC (tree, nargs + 4);
2252   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
2253
2254   /* Create the result variables.  */
2255   len = gfc_create_var (gfc_charlen_type_node, "len");
2256   args[0] = gfc_build_addr_expr (NULL_TREE, len);
2257   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
2258   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
2259   args[2] = build_int_cst (integer_type_node, op);
2260   args[3] = build_int_cst (integer_type_node, nargs / 2);
2261
2262   if (expr->ts.kind == 1)
2263     function = gfor_fndecl_string_minmax;
2264   else if (expr->ts.kind == 4)
2265     function = gfor_fndecl_string_minmax_char4;
2266   else
2267     gcc_unreachable ();
2268
2269   /* Make the function call.  */
2270   fndecl = build_addr (function, current_function_decl);
2271   tmp = build_call_array_loc (input_location,
2272                           TREE_TYPE (TREE_TYPE (function)), fndecl,
2273                           nargs + 4, args);
2274   gfc_add_expr_to_block (&se->pre, tmp);
2275
2276   /* Free the temporary afterwards, if necessary.  */
2277   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2278                           len, build_int_cst (TREE_TYPE (len), 0));
2279   tmp = gfc_call_free (var);
2280   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2281   gfc_add_expr_to_block (&se->post, tmp);
2282
2283   se->expr = var;
2284   se->string_length = len;
2285 }
2286
2287
2288 /* Create a symbol node for this intrinsic.  The symbol from the frontend
2289    has the generic name.  */
2290
2291 static gfc_symbol *
2292 gfc_get_symbol_for_expr (gfc_expr * expr)
2293 {
2294   gfc_symbol *sym;
2295
2296   /* TODO: Add symbols for intrinsic function to the global namespace.  */
2297   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
2298   sym = gfc_new_symbol (expr->value.function.name, NULL);
2299
2300   sym->ts = expr->ts;
2301   sym->attr.external = 1;
2302   sym->attr.function = 1;
2303   sym->attr.always_explicit = 1;
2304   sym->attr.proc = PROC_INTRINSIC;
2305   sym->attr.flavor = FL_PROCEDURE;
2306   sym->result = sym;
2307   if (expr->rank > 0)
2308     {
2309       sym->attr.dimension = 1;
2310       sym->as = gfc_get_array_spec ();
2311       sym->as->type = AS_ASSUMED_SHAPE;
2312       sym->as->rank = expr->rank;
2313     }
2314
2315   gfc_copy_formal_args_intr (sym, expr->value.function.isym);
2316
2317   return sym;
2318 }
2319
2320 /* Generate a call to an external intrinsic function.  */
2321 static void
2322 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
2323 {
2324   gfc_symbol *sym;
2325   VEC(tree,gc) *append_args;
2326
2327   gcc_assert (!se->ss || se->ss->expr == expr);
2328
2329   if (se->ss)
2330     gcc_assert (expr->rank > 0);
2331   else
2332     gcc_assert (expr->rank == 0);
2333
2334   sym = gfc_get_symbol_for_expr (expr);
2335
2336   /* Calls to libgfortran_matmul need to be appended special arguments,
2337      to be able to call the BLAS ?gemm functions if required and possible.  */
2338   append_args = NULL;
2339   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
2340       && sym->ts.type != BT_LOGICAL)
2341     {
2342       tree cint = gfc_get_int_type (gfc_c_int_kind);
2343
2344       if (gfc_option.flag_external_blas
2345           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
2346           && (sym->ts.kind == gfc_default_real_kind
2347               || sym->ts.kind == gfc_default_double_kind))
2348         {
2349           tree gemm_fndecl;
2350
2351           if (sym->ts.type == BT_REAL)
2352             {
2353               if (sym->ts.kind == gfc_default_real_kind)
2354                 gemm_fndecl = gfor_fndecl_sgemm;
2355               else
2356                 gemm_fndecl = gfor_fndecl_dgemm;
2357             }
2358           else
2359             {
2360               if (sym->ts.kind == gfc_default_real_kind)
2361                 gemm_fndecl = gfor_fndecl_cgemm;
2362               else
2363                 gemm_fndecl = gfor_fndecl_zgemm;
2364             }
2365
2366           append_args = VEC_alloc (tree, gc, 3);
2367           VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
2368           VEC_quick_push (tree, append_args,
2369                           build_int_cst (cint, gfc_option.blas_matmul_limit));
2370           VEC_quick_push (tree, append_args,
2371                           gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
2372         }
2373       else
2374         {
2375           append_args = VEC_alloc (tree, gc, 3);
2376           VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2377           VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2378           VEC_quick_push (tree, append_args, null_pointer_node);
2379         }
2380     }
2381
2382   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
2383                           append_args);
2384   gfc_free_symbol (sym);
2385 }
2386
2387 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2388    Implemented as
2389     any(a)
2390     {
2391       forall (i=...)
2392         if (a[i] != 0)
2393           return 1
2394       end forall
2395       return 0
2396     }
2397     all(a)
2398     {
2399       forall (i=...)
2400         if (a[i] == 0)
2401           return 0
2402       end forall
2403       return 1
2404     }
2405  */
2406 static void
2407 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
2408 {
2409   tree resvar;
2410   stmtblock_t block;
2411   stmtblock_t body;
2412   tree type;
2413   tree tmp;
2414   tree found;
2415   gfc_loopinfo loop;
2416   gfc_actual_arglist *actual;
2417   gfc_ss *arrayss;
2418   gfc_se arrayse;
2419   tree exit_label;
2420
2421   if (se->ss)
2422     {
2423       gfc_conv_intrinsic_funcall (se, expr);
2424       return;
2425     }
2426
2427   actual = expr->value.function.actual;
2428   type = gfc_typenode_for_spec (&expr->ts);
2429   /* Initialize the result.  */
2430   resvar = gfc_create_var (type, "test");
2431   if (op == EQ_EXPR)
2432     tmp = convert (type, boolean_true_node);
2433   else
2434     tmp = convert (type, boolean_false_node);
2435   gfc_add_modify (&se->pre, resvar, tmp);
2436
2437   /* Walk the arguments.  */
2438   arrayss = gfc_walk_expr (actual->expr);
2439   gcc_assert (arrayss != gfc_ss_terminator);
2440
2441   /* Initialize the scalarizer.  */
2442   gfc_init_loopinfo (&loop);
2443   exit_label = gfc_build_label_decl (NULL_TREE);
2444   TREE_USED (exit_label) = 1;
2445   gfc_add_ss_to_loop (&loop, arrayss);
2446
2447   /* Initialize the loop.  */
2448   gfc_conv_ss_startstride (&loop);
2449   gfc_conv_loop_setup (&loop, &expr->where);
2450
2451   gfc_mark_ss_chain_used (arrayss, 1);
2452   /* Generate the loop body.  */
2453   gfc_start_scalarized_body (&loop, &body);
2454
2455   /* If the condition matches then set the return value.  */
2456   gfc_start_block (&block);
2457   if (op == EQ_EXPR)
2458     tmp = convert (type, boolean_false_node);
2459   else
2460     tmp = convert (type, boolean_true_node);
2461   gfc_add_modify (&block, resvar, tmp);
2462
2463   /* And break out of the loop.  */
2464   tmp = build1_v (GOTO_EXPR, exit_label);
2465   gfc_add_expr_to_block (&block, tmp);
2466
2467   found = gfc_finish_block (&block);
2468
2469   /* Check this element.  */
2470   gfc_init_se (&arrayse, NULL);
2471   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2472   arrayse.ss = arrayss;
2473   gfc_conv_expr_val (&arrayse, actual->expr);
2474
2475   gfc_add_block_to_block (&body, &arrayse.pre);
2476   tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
2477                          build_int_cst (TREE_TYPE (arrayse.expr), 0));
2478   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
2479   gfc_add_expr_to_block (&body, tmp);
2480   gfc_add_block_to_block (&body, &arrayse.post);
2481
2482   gfc_trans_scalarizing_loops (&loop, &body);
2483
2484   /* Add the exit label.  */
2485   tmp = build1_v (LABEL_EXPR, exit_label);
2486   gfc_add_expr_to_block (&loop.pre, tmp);
2487
2488   gfc_add_block_to_block (&se->pre, &loop.pre);
2489   gfc_add_block_to_block (&se->pre, &loop.post);
2490   gfc_cleanup_loop (&loop);
2491
2492   se->expr = resvar;
2493 }
2494
2495 /* COUNT(A) = Number of true elements in A.  */
2496 static void
2497 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
2498 {
2499   tree resvar;
2500   tree type;
2501   stmtblock_t body;
2502   tree tmp;
2503   gfc_loopinfo loop;
2504   gfc_actual_arglist *actual;
2505   gfc_ss *arrayss;
2506   gfc_se arrayse;
2507
2508   if (se->ss)
2509     {
2510       gfc_conv_intrinsic_funcall (se, expr);
2511       return;
2512     }
2513
2514   actual = expr->value.function.actual;
2515
2516   type = gfc_typenode_for_spec (&expr->ts);
2517   /* Initialize the result.  */
2518   resvar = gfc_create_var (type, "count");
2519   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
2520
2521   /* Walk the arguments.  */
2522   arrayss = gfc_walk_expr (actual->expr);
2523   gcc_assert (arrayss != gfc_ss_terminator);
2524
2525   /* Initialize the scalarizer.  */
2526   gfc_init_loopinfo (&loop);
2527   gfc_add_ss_to_loop (&loop, arrayss);
2528
2529   /* Initialize the loop.  */
2530   gfc_conv_ss_startstride (&loop);
2531   gfc_conv_loop_setup (&loop, &expr->where);
2532
2533   gfc_mark_ss_chain_used (arrayss, 1);
2534   /* Generate the loop body.  */
2535   gfc_start_scalarized_body (&loop, &body);
2536
2537   tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
2538                          resvar, build_int_cst (TREE_TYPE (resvar), 1));
2539   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
2540
2541   gfc_init_se (&arrayse, NULL);
2542   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2543   arrayse.ss = arrayss;
2544   gfc_conv_expr_val (&arrayse, actual->expr);
2545   tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
2546                   build_empty_stmt (input_location));
2547
2548   gfc_add_block_to_block (&body, &arrayse.pre);
2549   gfc_add_expr_to_block (&body, tmp);
2550   gfc_add_block_to_block (&body, &arrayse.post);
2551
2552   gfc_trans_scalarizing_loops (&loop, &body);
2553
2554   gfc_add_block_to_block (&se->pre, &loop.pre);
2555   gfc_add_block_to_block (&se->pre, &loop.post);
2556   gfc_cleanup_loop (&loop);
2557
2558   se->expr = resvar;
2559 }
2560
2561 /* Inline implementation of the sum and product intrinsics.  */
2562 static void
2563 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
2564                           bool norm2)
2565 {
2566   tree resvar;
2567   tree scale = NULL_TREE;
2568   tree type;
2569   stmtblock_t body;
2570   stmtblock_t block;
2571   tree tmp;
2572   gfc_loopinfo loop;
2573   gfc_actual_arglist *actual;
2574   gfc_ss *arrayss;
2575   gfc_ss *maskss;
2576   gfc_se arrayse;
2577   gfc_se maskse;
2578   gfc_expr *arrayexpr;
2579   gfc_expr *maskexpr;
2580
2581   if (se->ss)
2582     {
2583       gfc_conv_intrinsic_funcall (se, expr);
2584       return;
2585     }
2586
2587   type = gfc_typenode_for_spec (&expr->ts);
2588   /* Initialize the result.  */
2589   resvar = gfc_create_var (type, "val");
2590   if (norm2)
2591     {
2592       /* result = 0.0;
2593          scale = 1.0.  */
2594       scale = gfc_create_var (type, "scale");
2595       gfc_add_modify (&se->pre, scale,
2596                       gfc_build_const (type, integer_one_node));
2597       tmp = gfc_build_const (type, integer_zero_node);
2598     }
2599   else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
2600     tmp = gfc_build_const (type, integer_zero_node);
2601   else if (op == NE_EXPR)
2602     /* PARITY.  */
2603     tmp = convert (type, boolean_false_node);
2604   else if (op == BIT_AND_EXPR)
2605     tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
2606                                                   type, integer_one_node));
2607   else
2608     tmp = gfc_build_const (type, integer_one_node);
2609
2610   gfc_add_modify (&se->pre, resvar, tmp);
2611
2612   /* Walk the arguments.  */
2613   actual = expr->value.function.actual;
2614   arrayexpr = actual->expr;
2615   arrayss = gfc_walk_expr (arrayexpr);
2616   gcc_assert (arrayss != gfc_ss_terminator);
2617
2618   if (op == NE_EXPR || norm2)
2619     /* PARITY and NORM2.  */
2620     maskexpr = NULL;
2621   else
2622     {
2623       actual = actual->next->next;
2624       gcc_assert (actual);
2625       maskexpr = actual->expr;
2626     }
2627
2628   if (maskexpr && maskexpr->rank != 0)
2629     {
2630       maskss = gfc_walk_expr (maskexpr);
2631       gcc_assert (maskss != gfc_ss_terminator);
2632     }
2633   else
2634     maskss = NULL;
2635
2636   /* Initialize the scalarizer.  */
2637   gfc_init_loopinfo (&loop);
2638   gfc_add_ss_to_loop (&loop, arrayss);
2639   if (maskss)
2640     gfc_add_ss_to_loop (&loop, maskss);
2641
2642   /* Initialize the loop.  */
2643   gfc_conv_ss_startstride (&loop);
2644   gfc_conv_loop_setup (&loop, &expr->where);
2645
2646   gfc_mark_ss_chain_used (arrayss, 1);
2647   if (maskss)
2648     gfc_mark_ss_chain_used (maskss, 1);
2649   /* Generate the loop body.  */
2650   gfc_start_scalarized_body (&loop, &body);
2651
2652   /* If we have a mask, only add this element if the mask is set.  */
2653   if (maskss)
2654     {
2655       gfc_init_se (&maskse, NULL);
2656       gfc_copy_loopinfo_to_se (&maskse, &loop);
2657       maskse.ss = maskss;
2658       gfc_conv_expr_val (&maskse, maskexpr);
2659       gfc_add_block_to_block (&body, &maskse.pre);
2660
2661       gfc_start_block (&block);
2662     }
2663   else
2664     gfc_init_block (&block);
2665
2666   /* Do the actual summation/product.  */
2667   gfc_init_se (&arrayse, NULL);
2668   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2669   arrayse.ss = arrayss;
2670   gfc_conv_expr_val (&arrayse, arrayexpr);
2671   gfc_add_block_to_block (&block, &arrayse.pre);
2672
2673   if (norm2)
2674     {
2675       /* if (x(i) != 0.0)
2676            {
2677              absX = abs(x(i))
2678              if (absX > scale)
2679                {
2680                  val = scale/absX;
2681                  result = 1.0 + result * val * val;
2682                  scale = absX;
2683                }
2684              else
2685                {
2686                  val = absX/scale;
2687                  result += val * val;
2688                }
2689            }  */
2690       tree res1, res2, cond, absX, val;
2691       stmtblock_t ifblock1, ifblock2, ifblock3;
2692
2693       gfc_init_block (&ifblock1);
2694
2695       absX = gfc_create_var (type, "absX");
2696       gfc_add_modify (&ifblock1, absX,
2697                       fold_build1_loc (input_location, ABS_EXPR, type,
2698                                        arrayse.expr));
2699       val = gfc_create_var (type, "val");
2700       gfc_add_expr_to_block (&ifblock1, val);
2701
2702       gfc_init_block (&ifblock2);
2703       gfc_add_modify (&ifblock2, val,
2704                       fold_build2_loc (input_location, RDIV_EXPR, type, scale,
2705                                        absX));
2706       res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
2707       res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
2708       res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
2709                               gfc_build_const (type, integer_one_node));
2710       gfc_add_modify (&ifblock2, resvar, res1);
2711       gfc_add_modify (&ifblock2, scale, absX);
2712       res1 = gfc_finish_block (&ifblock2); 
2713
2714       gfc_init_block (&ifblock3);
2715       gfc_add_modify (&ifblock3, val,
2716                       fold_build2_loc (input_location, RDIV_EXPR, type, absX,
2717                                        scale));
2718       res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
2719       res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
2720       gfc_add_modify (&ifblock3, resvar, res2);
2721       res2 = gfc_finish_block (&ifblock3);
2722
2723       cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2724                               absX, scale);
2725       tmp = build3_v (COND_EXPR, cond, res1, res2);
2726       gfc_add_expr_to_block (&ifblock1, tmp);  
2727       tmp = gfc_finish_block (&ifblock1);
2728
2729       cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2730                               arrayse.expr,
2731                               gfc_build_const (type, integer_zero_node));
2732
2733       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2734       gfc_add_expr_to_block (&block, tmp);  
2735     }
2736   else
2737     {
2738       tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
2739       gfc_add_modify (&block, resvar, tmp);
2740     }
2741
2742   gfc_add_block_to_block (&block, &arrayse.post);
2743
2744   if (maskss)
2745     {
2746       /* We enclose the above in if (mask) {...} .  */
2747
2748       tmp = gfc_finish_block (&block);
2749       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2750                       build_empty_stmt (input_location));
2751     }
2752   else
2753     tmp = gfc_finish_block (&block);
2754   gfc_add_expr_to_block (&body, tmp);
2755
2756   gfc_trans_scalarizing_loops (&loop, &body);
2757
2758   /* For a scalar mask, enclose the loop in an if statement.  */
2759   if (maskexpr && maskss == NULL)
2760     {
2761       gfc_init_se (&maskse, NULL);
2762       gfc_conv_expr_val (&maskse, maskexpr);
2763       gfc_init_block (&block);
2764       gfc_add_block_to_block (&block, &loop.pre);
2765       gfc_add_block_to_block (&block, &loop.post);
2766       tmp = gfc_finish_block (&block);
2767
2768       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2769                       build_empty_stmt (input_location));
2770       gfc_add_expr_to_block (&block, tmp);
2771       gfc_add_block_to_block (&se->pre, &block);
2772     }
2773   else
2774     {
2775       gfc_add_block_to_block (&se->pre, &loop.pre);
2776       gfc_add_block_to_block (&se->pre, &loop.post);
2777     }
2778
2779   gfc_cleanup_loop (&loop);
2780
2781   if (norm2)
2782     {
2783       /* result = scale * sqrt(result).  */
2784       tree sqrt;
2785       sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2786       resvar = build_call_expr_loc (input_location,
2787                                     sqrt, 1, resvar);
2788       resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
2789     }
2790
2791   se->expr = resvar;
2792 }
2793
2794
2795 /* Inline implementation of the dot_product intrinsic. This function
2796    is based on gfc_conv_intrinsic_arith (the previous function).  */
2797 static void
2798 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2799 {
2800   tree resvar;
2801   tree type;
2802   stmtblock_t body;
2803   stmtblock_t block;
2804   tree tmp;
2805   gfc_loopinfo loop;
2806   gfc_actual_arglist *actual;
2807   gfc_ss *arrayss1, *arrayss2;
2808   gfc_se arrayse1, arrayse2;
2809   gfc_expr *arrayexpr1, *arrayexpr2;
2810
2811   type = gfc_typenode_for_spec (&expr->ts);
2812
2813   /* Initialize the result.  */
2814   resvar = gfc_create_var (type, "val");
2815   if (expr->ts.type == BT_LOGICAL)
2816     tmp = build_int_cst (type, 0);
2817   else
2818     tmp = gfc_build_const (type, integer_zero_node);
2819
2820   gfc_add_modify (&se->pre, resvar, tmp);
2821
2822   /* Walk argument #1.  */
2823   actual = expr->value.function.actual;
2824   arrayexpr1 = actual->expr;
2825   arrayss1 = gfc_walk_expr (arrayexpr1);
2826   gcc_assert (arrayss1 != gfc_ss_terminator);
2827
2828   /* Walk argument #2.  */
2829   actual = actual->next;
2830   arrayexpr2 = actual->expr;
2831   arrayss2 = gfc_walk_expr (arrayexpr2);
2832   gcc_assert (arrayss2 != gfc_ss_terminator);
2833
2834   /* Initialize the scalarizer.  */
2835   gfc_init_loopinfo (&loop);
2836   gfc_add_ss_to_loop (&loop, arrayss1);
2837   gfc_add_ss_to_loop (&loop, arrayss2);
2838
2839   /* Initialize the loop.  */
2840   gfc_conv_ss_startstride (&loop);
2841   gfc_conv_loop_setup (&loop, &expr->where);
2842
2843   gfc_mark_ss_chain_used (arrayss1, 1);
2844   gfc_mark_ss_chain_used (arrayss2, 1);
2845
2846   /* Generate the loop body.  */
2847   gfc_start_scalarized_body (&loop, &body);
2848   gfc_init_block (&block);
2849
2850   /* Make the tree expression for [conjg(]array1[)].  */
2851   gfc_init_se (&arrayse1, NULL);
2852   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2853   arrayse1.ss = arrayss1;
2854   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2855   if (expr->ts.type == BT_COMPLEX)
2856     arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
2857                                      arrayse1.expr);
2858   gfc_add_block_to_block (&block, &arrayse1.pre);
2859
2860   /* Make the tree expression for array2.  */
2861   gfc_init_se (&arrayse2, NULL);
2862   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2863   arrayse2.ss = arrayss2;
2864   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2865   gfc_add_block_to_block (&block, &arrayse2.pre);
2866
2867   /* Do the actual product and sum.  */
2868   if (expr->ts.type == BT_LOGICAL)
2869     {
2870       tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
2871                              arrayse1.expr, arrayse2.expr);
2872       tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
2873     }
2874   else
2875     {
2876       tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
2877                              arrayse2.expr);
2878       tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
2879     }
2880   gfc_add_modify (&block, resvar, tmp);
2881
2882   /* Finish up the loop block and the loop.  */
2883   tmp = gfc_finish_block (&block);
2884   gfc_add_expr_to_block (&body, tmp);
2885
2886   gfc_trans_scalarizing_loops (&loop, &body);
2887   gfc_add_block_to_block (&se->pre, &loop.pre);
2888   gfc_add_block_to_block (&se->pre, &loop.post);
2889   gfc_cleanup_loop (&loop);
2890
2891   se->expr = resvar;
2892 }
2893
2894
2895 /* Emit code for minloc or maxloc intrinsic.  There are many different cases
2896    we need to handle.  For performance reasons we sometimes create two
2897    loops instead of one, where the second one is much simpler.
2898    Examples for minloc intrinsic:
2899    1) Result is an array, a call is generated
2900    2) Array mask is used and NaNs need to be supported:
2901       limit = Infinity;
2902       pos = 0;
2903       S = from;
2904       while (S <= to) {
2905         if (mask[S]) {
2906           if (pos == 0) pos = S + (1 - from);
2907           if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2908         }
2909         S++;
2910       }
2911       goto lab2;
2912       lab1:;
2913       while (S <= to) {
2914         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2915         S++;
2916       }
2917       lab2:;
2918    3) NaNs need to be supported, but it is known at compile time or cheaply
2919       at runtime whether array is nonempty or not:
2920       limit = Infinity;
2921       pos = 0;
2922       S = from;
2923       while (S <= to) {
2924         if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2925         S++;
2926       }
2927       if (from <= to) pos = 1;
2928       goto lab2;
2929       lab1:;
2930       while (S <= to) {
2931         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2932         S++;
2933       }
2934       lab2:;
2935    4) NaNs aren't supported, array mask is used:
2936       limit = infinities_supported ? Infinity : huge (limit);
2937       pos = 0;
2938       S = from;
2939       while (S <= to) {
2940         if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2941         S++;
2942       }
2943       goto lab2;
2944       lab1:;
2945       while (S <= to) {
2946         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2947         S++;
2948       }
2949       lab2:;
2950    5) Same without array mask:
2951       limit = infinities_supported ? Infinity : huge (limit);
2952       pos = (from <= to) ? 1 : 0;
2953       S = from;
2954       while (S <= to) {
2955         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2956         S++;
2957       }
2958    For 3) and 5), if mask is scalar, this all goes into a conditional,
2959    setting pos = 0; in the else branch.  */
2960
2961 static void
2962 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2963 {
2964   stmtblock_t body;
2965   stmtblock_t block;
2966   stmtblock_t ifblock;
2967   stmtblock_t elseblock;
2968   tree limit;
2969   tree type;
2970   tree tmp;
2971   tree cond;
2972   tree elsetmp;
2973   tree ifbody;
2974   tree offset;
2975   tree nonempty;
2976   tree lab1, lab2;
2977   gfc_loopinfo loop;
2978   gfc_actual_arglist *actual;
2979   gfc_ss *arrayss;
2980   gfc_ss *maskss;
2981   gfc_se arrayse;
2982   gfc_se maskse;
2983   gfc_expr *arrayexpr;
2984   gfc_expr *maskexpr;
2985   tree pos;
2986   int n;
2987
2988   if (se->ss)
2989     {
2990       gfc_conv_intrinsic_funcall (se, expr);
2991       return;
2992     }
2993
2994   /* Initialize the result.  */
2995   pos = gfc_create_var (gfc_array_index_type, "pos");
2996   offset = gfc_create_var (gfc_array_index_type, "offset");
2997   type = gfc_typenode_for_spec (&expr->ts);
2998
2999   /* Walk the arguments.  */
3000   actual = expr->value.function.actual;
3001   arrayexpr = actual->expr;
3002   arrayss = gfc_walk_expr (arrayexpr);
3003   gcc_assert (arrayss != gfc_ss_terminator);
3004
3005   actual = actual->next->next;
3006   gcc_assert (actual);
3007   maskexpr = actual->expr;
3008   nonempty = NULL;
3009   if (maskexpr && maskexpr->rank != 0)
3010     {
3011       maskss = gfc_walk_expr (maskexpr);
3012       gcc_assert (maskss != gfc_ss_terminator);
3013     }
3014   else
3015     {
3016       mpz_t asize;
3017       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3018         {
3019           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3020           mpz_clear (asize);
3021           nonempty = fold_build2_loc (input_location, GT_EXPR,
3022                                       boolean_type_node, nonempty,
3023                                       gfc_index_zero_node);
3024         }
3025       maskss = NULL;
3026     }
3027
3028   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
3029   switch (arrayexpr->ts.type)
3030     {
3031     case BT_REAL:
3032       tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
3033       break;
3034
3035     case BT_INTEGER:
3036       n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
3037       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
3038                                   arrayexpr->ts.kind);
3039       break;
3040
3041     default:
3042       gcc_unreachable ();
3043     }
3044
3045   /* We start with the most negative possible value for MAXLOC, and the most
3046      positive possible value for MINLOC. The most negative possible value is
3047      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3048      possible value is HUGE in both cases.  */
3049   if (op == GT_EXPR)
3050     tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3051   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3052     tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
3053                            build_int_cst (type, 1));
3054
3055   gfc_add_modify (&se->pre, limit, tmp);
3056
3057   /* Initialize the scalarizer.  */
3058   gfc_init_loopinfo (&loop);
3059   gfc_add_ss_to_loop (&loop, arrayss);
3060   if (maskss)
3061     gfc_add_ss_to_loop (&loop, maskss);
3062
3063   /* Initialize the loop.  */
3064   gfc_conv_ss_startstride (&loop);
3065   gfc_conv_loop_setup (&loop, &expr->where);
3066
3067   gcc_assert (loop.dimen == 1);
3068   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
3069     nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3070                                 loop.from[0], loop.to[0]);
3071
3072   lab1 = NULL;
3073   lab2 = NULL;
3074   /* Initialize the position to zero, following Fortran 2003.  We are free
3075      to do this because Fortran 95 allows the result of an entirely false
3076      mask to be processor dependent.  If we know at compile time the array
3077      is non-empty and no MASK is used, we can initialize to 1 to simplify
3078      the inner loop.  */
3079   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
3080     gfc_add_modify (&loop.pre, pos,
3081                     fold_build3_loc (input_location, COND_EXPR,
3082                                      gfc_array_index_type,
3083                                      nonempty, gfc_index_one_node,
3084                                      gfc_index_zero_node));
3085   else
3086     {
3087       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
3088       lab1 = gfc_build_label_decl (NULL_TREE);
3089       TREE_USED (lab1) = 1;
3090       lab2 = gfc_build_label_decl (NULL_TREE);
3091       TREE_USED (lab2) = 1;
3092     }
3093
3094   gfc_mark_ss_chain_used (arrayss, 1);
3095   if (maskss)
3096     gfc_mark_ss_chain_used (maskss, 1);
3097   /* Generate the loop body.  */
3098   gfc_start_scalarized_body (&loop, &body);
3099
3100   /* If we have a mask, only check this element if the mask is set.  */
3101   if (maskss)
3102     {
3103       gfc_init_se (&maskse, NULL);
3104       gfc_copy_loopinfo_to_se (&maskse, &loop);
3105       maskse.ss = maskss;
3106       gfc_conv_expr_val (&maskse, maskexpr);
3107       gfc_add_block_to_block (&body, &maskse.pre);
3108
3109       gfc_start_block (&block);
3110     }
3111   else
3112     gfc_init_block (&block);
3113
3114   /* Compare with the current limit.  */
3115   gfc_init_se (&arrayse, NULL);
3116   gfc_copy_loopinfo_to_se (&arrayse, &loop);
3117   arrayse.ss = arrayss;
3118   gfc_conv_expr_val (&arrayse, arrayexpr);
3119   gfc_add_block_to_block (&block, &arrayse.pre);
3120
3121   /* We do the following if this is a more extreme value.  */
3122   gfc_start_block (&ifblock);
3123
3124   /* Assign the value to the limit...  */
3125   gfc_add_modify (&ifblock, limit, arrayse.expr);
3126
3127   /* Remember where we are.  An offset must be added to the loop
3128      counter to obtain the required position.  */
3129   if (loop.from[0])
3130     tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3131                            gfc_index_one_node, loop.from[0]);
3132   else
3133     tmp = gfc_index_one_node;
3134
3135   gfc_add_modify (&block, offset, tmp);
3136
3137   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
3138     {
3139       stmtblock_t ifblock2;
3140       tree ifbody2;
3141
3142       gfc_start_block (&ifblock2);
3143       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3144                              loop.loopvar[0], offset);
3145       gfc_add_modify (&ifblock2, pos, tmp);
3146       ifbody2 = gfc_finish_block (&ifblock2);
3147       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
3148                               gfc_index_zero_node);
3149       tmp = build3_v (COND_EXPR, cond, ifbody2,
3150                       build_empty_stmt (input_location));
3151       gfc_add_expr_to_block (&block, tmp);
3152     }
3153
3154   tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3155                          loop.loopvar[0], offset);
3156   gfc_add_modify (&ifblock, pos, tmp);
3157
3158   if (lab1)
3159     gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
3160
3161   ifbody = gfc_finish_block (&ifblock);
3162
3163   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
3164     {
3165       if (lab1)
3166         cond = fold_build2_loc (input_location,
3167                                 op == GT_EXPR ? GE_EXPR : LE_EXPR,
3168                                 boolean_type_node, arrayse.expr, limit);
3169       else
3170         cond = fold_build2_loc (input_location, op, boolean_type_node,
3171                                 arrayse.expr, limit);
3172
3173       ifbody = build3_v (COND_EXPR, cond, ifbody,
3174                          build_empty_stmt (input_location));
3175     }
3176   gfc_add_expr_to_block (&block, ifbody);
3177
3178   if (maskss)
3179     {
3180       /* We enclose the above in if (mask) {...}.  */
3181       tmp = gfc_finish_block (&block);
3182
3183       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3184                       build_empty_stmt (input_location));
3185     }
3186   else
3187     tmp = gfc_finish_block (&block);
3188   gfc_add_expr_to_block (&body, tmp);
3189
3190   if (lab1)
3191     {
3192       gfc_trans_scalarized_loop_end (&loop, 0, &body);
3193
3194       if (HONOR_NANS (DECL_MODE (limit)))
3195         {
3196           if (nonempty != NULL)
3197             {
3198               ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
3199               tmp = build3_v (COND_EXPR, nonempty, ifbody,
3200                               build_empty_stmt (input_location));
3201               gfc_add_expr_to_block (&loop.code[0], tmp);
3202             }
3203         }
3204
3205       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
3206       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
3207       gfc_start_block (&body);
3208
3209       /* If we have a mask, only check this element if the mask is set.  */
3210       if (maskss)
3211         {
3212           gfc_init_se (&maskse, NULL);
3213           gfc_copy_loopinfo_to_se (&maskse, &loop);
3214           maskse.ss = maskss;
3215           gfc_conv_expr_val (&maskse, maskexpr);
3216           gfc_add_block_to_block (&body, &maskse.pre);
3217
3218           gfc_start_block (&block);
3219         }
3220       else
3221         gfc_init_block (&block);
3222
3223       /* Compare with the current limit.  */
3224       gfc_init_se (&arrayse, NULL);
3225       gfc_copy_loopinfo_to_se (&arrayse, &loop);
3226       arrayse.ss = arrayss;
3227       gfc_conv_expr_val (&arrayse, arrayexpr);
3228       gfc_add_block_to_block (&block, &arrayse.pre);
3229
3230       /* We do the following if this is a more extreme value.  */
3231       gfc_start_block (&ifblock);
3232
3233       /* Assign the value to the limit...  */
3234       gfc_add_modify (&ifblock, limit, arrayse.expr);
3235
3236       /* Remember where we are.  An offset must be added to the loop
3237          counter to obtain the required position.  */
3238       if (loop.from[0])
3239         tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3240                                gfc_index_one_node, loop.from[0]);
3241       else
3242         tmp = gfc_index_one_node;
3243
3244       gfc_add_modify (&block, offset, tmp);
3245
3246       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3247                              loop.loopvar[0], offset);
3248       gfc_add_modify (&ifblock, pos, tmp);
3249
3250       ifbody = gfc_finish_block (&ifblock);
3251
3252       cond = fold_build2_loc (input_location, op, boolean_type_node,
3253                               arrayse.expr, limit);
3254
3255       tmp = build3_v (COND_EXPR, cond, ifbody,
3256                       build_empty_stmt (input_location));
3257       gfc_add_expr_to_block (&block, tmp);
3258
3259       if (maskss)
3260         {
3261           /* We enclose the above in if (mask) {...}.  */
3262           tmp = gfc_finish_block (&block);
3263
3264           tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3265                           build_empty_stmt (input_location));
3266         }
3267       else
3268         tmp = gfc_finish_block (&block);
3269       gfc_add_expr_to_block (&body, tmp);
3270       /* Avoid initializing loopvar[0] again, it should be left where
3271          it finished by the first loop.  */
3272       loop.from[0] = loop.loopvar[0];
3273     }
3274
3275   gfc_trans_scalarizing_loops (&loop, &body);
3276
3277   if (lab2)
3278     gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
3279
3280   /* For a scalar mask, enclose the loop in an if statement.  */
3281   if (maskexpr && maskss == NULL)
3282     {
3283       gfc_init_se (&maskse, NULL);
3284       gfc_conv_expr_val (&maskse, maskexpr);
3285       gfc_init_block (&block);
3286       gfc_add_block_to_block (&block, &loop.pre);
3287       gfc_add_block_to_block (&block, &loop.post);
3288       tmp = gfc_finish_block (&block);
3289
3290       /* For the else part of the scalar mask, just initialize
3291          the pos variable the same way as above.  */
3292
3293       gfc_init_block (&elseblock);
3294       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
3295       elsetmp = gfc_finish_block (&elseblock);
3296
3297       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
3298       gfc_add_expr_to_block (&block, tmp);
3299       gfc_add_block_to_block (&se->pre, &block);
3300     }
3301   else
3302     {
3303       gfc_add_block_to_block (&se->pre, &loop.pre);
3304       gfc_add_block_to_block (&se->pre, &loop.post);
3305     }
3306   gfc_cleanup_loop (&loop);
3307
3308   se->expr = convert (type, pos);
3309 }
3310
3311 /* Emit code for minval or maxval intrinsic.  There are many different cases
3312    we need to handle.  For performance reasons we sometimes create two
3313    loops instead of one, where the second one is much simpler.
3314    Examples for minval intrinsic:
3315    1) Result is an array, a call is generated
3316    2) Array mask is used and NaNs need to be supported, rank 1:
3317       limit = Infinity;
3318       nonempty = false;
3319       S = from;
3320       while (S <= to) {
3321         if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3322         S++;
3323       }
3324       limit = nonempty ? NaN : huge (limit);
3325       lab:
3326       while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3327    3) NaNs need to be supported, but it is known at compile time or cheaply
3328       at runtime whether array is nonempty or not, rank 1:
3329       limit = Infinity;
3330       S = from;
3331       while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3332       limit = (from <= to) ? NaN : huge (limit);
3333       lab:
3334       while (S <= to) { limit = min (a[S], limit); S++; }
3335    4) Array mask is used and NaNs need to be supported, rank > 1:
3336       limit = Infinity;
3337       nonempty = false;
3338       fast = false;
3339       S1 = from1;
3340       while (S1 <= to1) {
3341         S2 = from2;
3342         while (S2 <= to2) {
3343           if (mask[S1][S2]) {
3344             if (fast) limit = min (a[S1][S2], limit);
3345             else {
3346               nonempty = true;
3347               if (a[S1][S2] <= limit) {
3348                 limit = a[S1][S2];
3349                 fast = true;
3350               }
3351             }
3352           }
3353           S2++;
3354         }
3355         S1++;
3356       }
3357       if (!fast)
3358         limit = nonempty ? NaN : huge (limit);
3359    5) NaNs need to be supported, but it is known at compile time or cheaply
3360       at runtime whether array is nonempty or not, rank > 1:
3361       limit = Infinity;
3362       fast = false;
3363       S1 = from1;
3364       while (S1 <= to1) {
3365         S2 = from2;
3366         while (S2 <= to2) {
3367           if (fast) limit = min (a[S1][S2], limit);
3368           else {
3369             if (a[S1][S2] <= limit) {
3370               limit = a[S1][S2];
3371               fast = true;
3372             }
3373           }
3374           S2++;
3375         }
3376         S1++;
3377       }
3378       if (!fast)
3379         limit = (nonempty_array) ? NaN : huge (limit);
3380    6) NaNs aren't supported, but infinities are.  Array mask is used:
3381       limit = Infinity;
3382       nonempty = false;
3383       S = from;