OSDN Git Service

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