OSDN Git Service

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