OSDN Git Service

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