OSDN Git Service

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