OSDN Git Service

PR fortran/26025
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-intrinsic.c
1 /* Intrinsic translation
2    Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3    Contributed by Paul Brook <paul@nowt.org>
4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
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 "tree.h"
29 #include "ggc.h"
30 #include "toplev.h"
31 #include "real.h"
32 #include "tree-gimple.h"
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 gfc_intrinsic_map_t      GTY(())
48 {
49   /* The explicit enum is required to work around inadequacies in the
50      garbage collection/gengtype parsing mechanism.  */
51   enum gfc_generic_isym_id id;
52
53   /* Enum value from the "language-independent", aka C-centric, part
54      of gcc, or END_BUILTINS of no such value set.  */
55   enum built_in_function code_r4;
56   enum built_in_function code_r8;
57   enum built_in_function code_r10;
58   enum built_in_function code_r16;
59   enum built_in_function code_c4;
60   enum built_in_function code_c8;
61   enum built_in_function code_c10;
62   enum built_in_function code_c16;
63
64   /* True if the naming pattern is to prepend "c" for complex and
65      append "f" for kind=4.  False if the naming pattern is to
66      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
67   bool libm_name;
68
69   /* True if a complex version of the function exists.  */
70   bool complex_available;
71
72   /* True if the function should be marked const.  */
73   bool is_constant;
74
75   /* The base library name of this function.  */
76   const char *name;
77
78   /* Cache decls created for the various operand types.  */
79   tree real4_decl;
80   tree real8_decl;
81   tree real10_decl;
82   tree real16_decl;
83   tree complex4_decl;
84   tree complex8_decl;
85   tree complex10_decl;
86   tree complex16_decl;
87 }
88 gfc_intrinsic_map_t;
89
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91    defines complex variants of all of the entries in mathbuiltins.def
92    except for atan2.  */
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
96     false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
98
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
102     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
103     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
104     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105
106 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109     true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111
112 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
113   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
116     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
117
118 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
119 {
120   /* Functions built into gcc itself.  */
121 #include "mathbuiltins.def"
122
123   /* Functions in libm.  */
124   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
125      pattern for other mathbuiltins.def entries.  At present we have no
126      optimizations for this in the common sources.  */
127   LIBM_FUNCTION (SCALE, "scalbn", false),
128
129   /* Functions in libgfortran.  */
130   LIBF_FUNCTION (FRACTION, "fraction", false),
131   LIBF_FUNCTION (NEAREST, "nearest", false),
132   LIBF_FUNCTION (RRSPACING, "rrspacing", false),
133   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
134   LIBF_FUNCTION (SPACING, "spacing", false),
135
136   /* End the list.  */
137   LIBF_FUNCTION (NONE, NULL, false)
138 };
139 #undef DEFINE_MATH_BUILTIN
140 #undef DEFINE_MATH_BUILTIN_C
141 #undef LIBM_FUNCTION
142 #undef LIBF_FUNCTION
143
144 /* Structure for storing components of a floating number to be used by
145    elemental functions to manipulate reals.  */
146 typedef struct
147 {
148   tree arg;     /* Variable tree to view convert to integer.  */
149   tree expn;    /* Variable tree to save exponent.  */
150   tree frac;    /* Variable tree to save fraction.  */
151   tree smask;   /* Constant tree of sign's mask.  */
152   tree emask;   /* Constant tree of exponent's mask.  */
153   tree fmask;   /* Constant tree of fraction's mask.  */
154   tree edigits; /* Constant tree of the number of exponent bits.  */
155   tree fdigits; /* Constant tree of the number of fraction bits.  */
156   tree f1;      /* Constant tree of the f1 defined in the real model.  */
157   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
158   tree type;    /* Type tree of arg1.  */
159   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
160 }
161 real_compnt_info;
162
163
164 /* Evaluate the arguments to an intrinsic function.  */
165
166 static tree
167 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
168 {
169   gfc_actual_arglist *actual;
170   gfc_expr *e;
171   gfc_intrinsic_arg  *formal;
172   gfc_se argse;
173   tree args;
174
175   args = NULL_TREE;
176   formal = expr->value.function.isym->formal;
177
178   for (actual = expr->value.function.actual; actual; actual = actual->next,
179        formal = formal ? formal->next : NULL)
180     {
181       e = actual->expr;
182       /* Skip omitted optional arguments.  */
183       if (!e)
184         continue;
185
186       /* Evaluate the parameter.  This will substitute scalarized
187          references automatically.  */
188       gfc_init_se (&argse, se);
189
190       if (e->ts.type == BT_CHARACTER)
191         {
192           gfc_conv_expr (&argse, e);
193           gfc_conv_string_parameter (&argse);
194           args = gfc_chainon_list (args, argse.string_length);
195         }
196       else
197         gfc_conv_expr_val (&argse, e);
198
199       /* If an optional argument is itself an optional dummy argument,
200          check its presence and substitute a null if absent.  */
201       if (e->expr_type ==EXPR_VARIABLE
202             && e->symtree->n.sym->attr.optional
203             && formal
204             && formal->optional)
205         gfc_conv_missing_dummy (&argse, e, formal->ts);
206
207       gfc_add_block_to_block (&se->pre, &argse.pre);
208       gfc_add_block_to_block (&se->post, &argse.post);
209       args = gfc_chainon_list (args, argse.expr);
210     }
211   return args;
212 }
213
214
215 /* Conversions between different types are output by the frontend as
216    intrinsic functions.  We implement these directly with inline code.  */
217
218 static void
219 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
220 {
221   tree type;
222   tree arg;
223
224   /* Evaluate the argument.  */
225   type = gfc_typenode_for_spec (&expr->ts);
226   gcc_assert (expr->value.function.actual->expr);
227   arg = gfc_conv_intrinsic_function_args (se, expr);
228   arg = TREE_VALUE (arg);
229
230   /* Conversion from complex to non-complex involves taking the real
231      component of the value.  */
232   if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
233       && expr->ts.type != BT_COMPLEX)
234     {
235       tree artype;
236
237       artype = TREE_TYPE (TREE_TYPE (arg));
238       arg = build1 (REALPART_EXPR, artype, arg);
239     }
240
241   se->expr = convert (type, arg);
242 }
243
244 /* This is needed because the gcc backend only implements
245    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
246    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
247    Similarly for CEILING.  */
248
249 static tree
250 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
251 {
252   tree tmp;
253   tree cond;
254   tree argtype;
255   tree intval;
256
257   argtype = TREE_TYPE (arg);
258   arg = gfc_evaluate_now (arg, pblock);
259
260   intval = convert (type, arg);
261   intval = gfc_evaluate_now (intval, pblock);
262
263   tmp = convert (argtype, intval);
264   cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
265
266   tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
267                 build_int_cst (type, 1));
268   tmp = build3 (COND_EXPR, type, cond, intval, tmp);
269   return tmp;
270 }
271
272
273 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
274    NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */
275
276 static tree
277 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
278 {
279   tree tmp;
280   tree cond;
281   tree neg;
282   tree pos;
283   tree argtype;
284   REAL_VALUE_TYPE r;
285
286   argtype = TREE_TYPE (arg);
287   arg = gfc_evaluate_now (arg, pblock);
288
289   real_from_string (&r, "0.5");
290   pos = build_real (argtype, r);
291
292   real_from_string (&r, "-0.5");
293   neg = build_real (argtype, r);
294
295   tmp = gfc_build_const (argtype, integer_zero_node);
296   cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
297
298   tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
299   tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
300   return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
301 }
302
303
304 /* Convert a real to an integer using a specific rounding mode.
305    Ideally we would just build the corresponding GENERIC node,
306    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
307
308 static tree
309 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
310                enum tree_code op)
311 {
312   switch (op)
313     {
314     case FIX_FLOOR_EXPR:
315       return build_fixbound_expr (pblock, arg, type, 0);
316       break;
317
318     case FIX_CEIL_EXPR:
319       return build_fixbound_expr (pblock, arg, type, 1);
320       break;
321
322     case FIX_ROUND_EXPR:
323       return build_round_expr (pblock, arg, type);
324
325     default:
326       return build1 (op, type, arg);
327     }
328 }
329
330
331 /* Round a real value using the specified rounding mode.
332    We use a temporary integer of that same kind size as the result.
333    Values larger than those that can be represented by this kind are
334    unchanged, as they will not be accurate enough to represent the
335    rounding.
336     huge = HUGE (KIND (a))
337     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
338    */
339
340 static void
341 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
342 {
343   tree type;
344   tree itype;
345   tree arg;
346   tree tmp;
347   tree cond;
348   mpfr_t huge;
349   int n;
350   int kind;
351
352   kind = expr->ts.kind;
353
354   n = END_BUILTINS;
355   /* We have builtin functions for some cases.  */
356   switch (op)
357     {
358     case FIX_ROUND_EXPR:
359       switch (kind)
360         {
361         case 4:
362           n = BUILT_IN_ROUNDF;
363           break;
364
365         case 8:
366           n = BUILT_IN_ROUND;
367           break;
368
369         case 10:
370         case 16:
371           n = BUILT_IN_ROUNDL;
372           break;
373         }
374       break;
375
376     case FIX_TRUNC_EXPR:
377       switch (kind)
378         {
379         case 4:
380           n = BUILT_IN_TRUNCF;
381           break;
382
383         case 8:
384           n = BUILT_IN_TRUNC;
385           break;
386
387         case 10:
388         case 16:
389           n = BUILT_IN_TRUNCL;
390           break;
391         }
392       break;
393
394     default:
395       gcc_unreachable ();
396     }
397
398   /* Evaluate the argument.  */
399   gcc_assert (expr->value.function.actual->expr);
400   arg = gfc_conv_intrinsic_function_args (se, expr);
401
402   /* Use a builtin function if one exists.  */
403   if (n != END_BUILTINS)
404     {
405       tmp = built_in_decls[n];
406       se->expr = build_function_call_expr (tmp, arg);
407       return;
408     }
409
410   /* This code is probably redundant, but we'll keep it lying around just
411      in case.  */
412   type = gfc_typenode_for_spec (&expr->ts);
413   arg = TREE_VALUE (arg);
414   arg = gfc_evaluate_now (arg, &se->pre);
415
416   /* Test if the value is too large to handle sensibly.  */
417   gfc_set_model_kind (kind);
418   mpfr_init (huge);
419   n = gfc_validate_kind (BT_INTEGER, kind, false);
420   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
421   tmp = gfc_conv_mpfr_to_tree (huge, kind);
422   cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
423
424   mpfr_neg (huge, huge, GFC_RND_MODE);
425   tmp = gfc_conv_mpfr_to_tree (huge, kind);
426   tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
427   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
428   itype = gfc_get_int_type (kind);
429
430   tmp = build_fix_expr (&se->pre, arg, itype, op);
431   tmp = convert (type, tmp);
432   se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
433   mpfr_clear (huge);
434 }
435
436
437 /* Convert to an integer using the specified rounding mode.  */
438
439 static void
440 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
441 {
442   tree type;
443   tree arg;
444
445   /* Evaluate the argument.  */
446   type = gfc_typenode_for_spec (&expr->ts);
447   gcc_assert (expr->value.function.actual->expr);
448   arg = gfc_conv_intrinsic_function_args (se, expr);
449   arg = TREE_VALUE (arg);
450
451   if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
452     {
453       /* Conversion to a different integer kind.  */
454       se->expr = convert (type, arg);
455     }
456   else
457     {
458       /* Conversion from complex to non-complex involves taking the real
459          component of the value.  */
460       if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
461           && expr->ts.type != BT_COMPLEX)
462         {
463           tree artype;
464
465           artype = TREE_TYPE (TREE_TYPE (arg));
466           arg = build1 (REALPART_EXPR, artype, arg);
467         }
468
469       se->expr = build_fix_expr (&se->pre, arg, type, op);
470     }
471 }
472
473
474 /* Get the imaginary component of a value.  */
475
476 static void
477 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
478 {
479   tree arg;
480
481   arg = gfc_conv_intrinsic_function_args (se, expr);
482   arg = TREE_VALUE (arg);
483   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
484 }
485
486
487 /* Get the complex conjugate of a value.  */
488
489 static void
490 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
491 {
492   tree arg;
493
494   arg = gfc_conv_intrinsic_function_args (se, expr);
495   arg = TREE_VALUE (arg);
496   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
497 }
498
499
500 /* Initialize function decls for library functions.  The external functions
501    are created as required.  Builtin functions are added here.  */
502
503 void
504 gfc_build_intrinsic_lib_fndecls (void)
505 {
506   gfc_intrinsic_map_t *m;
507
508   /* Add GCC builtin functions.  */
509   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
510     {
511       if (m->code_r4 != END_BUILTINS)
512         m->real4_decl = built_in_decls[m->code_r4];
513       if (m->code_r8 != END_BUILTINS)
514         m->real8_decl = built_in_decls[m->code_r8];
515       if (m->code_r10 != END_BUILTINS)
516         m->real10_decl = built_in_decls[m->code_r10];
517       if (m->code_r16 != END_BUILTINS)
518         m->real16_decl = built_in_decls[m->code_r16];
519       if (m->code_c4 != END_BUILTINS)
520         m->complex4_decl = built_in_decls[m->code_c4];
521       if (m->code_c8 != END_BUILTINS)
522         m->complex8_decl = built_in_decls[m->code_c8];
523       if (m->code_c10 != END_BUILTINS)
524         m->complex10_decl = built_in_decls[m->code_c10];
525       if (m->code_c16 != END_BUILTINS)
526         m->complex16_decl = built_in_decls[m->code_c16];
527     }
528 }
529
530
531 /* Create a fndecl for a simple intrinsic library function.  */
532
533 static tree
534 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
535 {
536   tree type;
537   tree argtypes;
538   tree fndecl;
539   gfc_actual_arglist *actual;
540   tree *pdecl;
541   gfc_typespec *ts;
542   char name[GFC_MAX_SYMBOL_LEN + 3];
543
544   ts = &expr->ts;
545   if (ts->type == BT_REAL)
546     {
547       switch (ts->kind)
548         {
549         case 4:
550           pdecl = &m->real4_decl;
551           break;
552         case 8:
553           pdecl = &m->real8_decl;
554           break;
555         case 10:
556           pdecl = &m->real10_decl;
557           break;
558         case 16:
559           pdecl = &m->real16_decl;
560           break;
561         default:
562           gcc_unreachable ();
563         }
564     }
565   else if (ts->type == BT_COMPLEX)
566     {
567       gcc_assert (m->complex_available);
568
569       switch (ts->kind)
570         {
571         case 4:
572           pdecl = &m->complex4_decl;
573           break;
574         case 8:
575           pdecl = &m->complex8_decl;
576           break;
577         case 10:
578           pdecl = &m->complex10_decl;
579           break;
580         case 16:
581           pdecl = &m->complex16_decl;
582           break;
583         default:
584           gcc_unreachable ();
585         }
586     }
587   else
588     gcc_unreachable ();
589
590   if (*pdecl)
591     return *pdecl;
592
593   if (m->libm_name)
594     {
595       if (ts->kind == 4)
596         snprintf (name, sizeof (name), "%s%s%s",
597                 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
598       else if (ts->kind == 8)
599         snprintf (name, sizeof (name), "%s%s",
600                 ts->type == BT_COMPLEX ? "c" : "", m->name);
601       else
602         {
603           gcc_assert (ts->kind == 10 || ts->kind == 16);
604           snprintf (name, sizeof (name), "%s%s%s",
605                 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
606         }
607     }
608   else
609     {
610       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
611                 ts->type == BT_COMPLEX ? 'c' : 'r',
612                 ts->kind);
613     }
614
615   argtypes = NULL_TREE;
616   for (actual = expr->value.function.actual; actual; actual = actual->next)
617     {
618       type = gfc_typenode_for_spec (&actual->expr->ts);
619       argtypes = gfc_chainon_list (argtypes, type);
620     }
621   argtypes = gfc_chainon_list (argtypes, void_type_node);
622   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
623   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
624
625   /* Mark the decl as external.  */
626   DECL_EXTERNAL (fndecl) = 1;
627   TREE_PUBLIC (fndecl) = 1;
628
629   /* Mark it __attribute__((const)), if possible.  */
630   TREE_READONLY (fndecl) = m->is_constant;
631
632   rest_of_decl_compilation (fndecl, 1, 0);
633
634   (*pdecl) = fndecl;
635   return fndecl;
636 }
637
638
639 /* Convert an intrinsic function into an external or builtin call.  */
640
641 static void
642 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
643 {
644   gfc_intrinsic_map_t *m;
645   tree args;
646   tree fndecl;
647   gfc_generic_isym_id id;
648
649   id = expr->value.function.isym->generic_id;
650   /* Find the entry for this function.  */
651   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
652     {
653       if (id == m->id)
654         break;
655     }
656
657   if (m->id == GFC_ISYM_NONE)
658     {
659       internal_error ("Intrinsic function %s(%d) not recognized",
660                       expr->value.function.name, id);
661     }
662
663   /* Get the decl and generate the call.  */
664   args = gfc_conv_intrinsic_function_args (se, expr);
665   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
666   se->expr = build_function_call_expr (fndecl, args);
667 }
668
669 /* Generate code for EXPONENT(X) intrinsic function.  */
670
671 static void
672 gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
673 {
674   tree args, fndecl;
675   gfc_expr *a1;
676
677   args = gfc_conv_intrinsic_function_args (se, expr);
678
679   a1 = expr->value.function.actual->expr;
680   switch (a1->ts.kind)
681     {
682     case 4:
683       fndecl = gfor_fndecl_math_exponent4;
684       break;
685     case 8:
686       fndecl = gfor_fndecl_math_exponent8;
687       break;
688     case 10:
689       fndecl = gfor_fndecl_math_exponent10;
690       break;
691     case 16:
692       fndecl = gfor_fndecl_math_exponent16;
693       break;
694     default:
695       gcc_unreachable ();
696     }
697
698   se->expr = build_function_call_expr (fndecl, args);
699 }
700
701 /* Evaluate a single upper or lower bound.  */
702 /* TODO: bound intrinsic generates way too much unnecessary code.  */
703
704 static void
705 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
706 {
707   gfc_actual_arglist *arg;
708   gfc_actual_arglist *arg2;
709   tree desc;
710   tree type;
711   tree bound;
712   tree tmp;
713   tree cond, cond1, cond2, cond3, size;
714   tree ubound;
715   tree lbound;
716   gfc_se argse;
717   gfc_ss *ss;
718   gfc_array_spec * as;
719   gfc_ref *ref;
720   int i;
721
722   arg = expr->value.function.actual;
723   arg2 = arg->next;
724
725   if (se->ss)
726     {
727       /* Create an implicit second parameter from the loop variable.  */
728       gcc_assert (!arg2->expr);
729       gcc_assert (se->loop->dimen == 1);
730       gcc_assert (se->ss->expr == expr);
731       gfc_advance_se_ss_chain (se);
732       bound = se->loop->loopvar[0];
733       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
734                            se->loop->from[0]);
735     }
736   else
737     {
738       /* use the passed argument.  */
739       gcc_assert (arg->next->expr);
740       gfc_init_se (&argse, NULL);
741       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
742       gfc_add_block_to_block (&se->pre, &argse.pre);
743       bound = argse.expr;
744       /* Convert from one based to zero based.  */
745       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
746                            gfc_index_one_node);
747     }
748
749   /* TODO: don't re-evaluate the descriptor on each iteration.  */
750   /* Get a descriptor for the first parameter.  */
751   ss = gfc_walk_expr (arg->expr);
752   gcc_assert (ss != gfc_ss_terminator);
753   gfc_init_se (&argse, NULL);
754   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
755   gfc_add_block_to_block (&se->pre, &argse.pre);
756   gfc_add_block_to_block (&se->post, &argse.post);
757
758   desc = argse.expr;
759
760   if (INTEGER_CST_P (bound))
761     {
762       gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
763       i = TREE_INT_CST_LOW (bound);
764       gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
765     }
766   else
767     {
768       if (flag_bounds_check)
769         {
770           bound = gfc_evaluate_now (bound, &se->pre);
771           cond = fold_build2 (LT_EXPR, boolean_type_node,
772                               bound, build_int_cst (TREE_TYPE (bound), 0));
773           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
774           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
775           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
776           gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL);
777         }
778     }
779
780   ubound = gfc_conv_descriptor_ubound (desc, bound);
781   lbound = gfc_conv_descriptor_lbound (desc, bound);
782   
783   /* Follow any component references.  */
784   if (arg->expr->expr_type == EXPR_VARIABLE
785       || arg->expr->expr_type == EXPR_CONSTANT)
786     {
787       as = arg->expr->symtree->n.sym->as;
788       for (ref = arg->expr->ref; ref; ref = ref->next)
789         {
790           switch (ref->type)
791             {
792             case REF_COMPONENT:
793               as = ref->u.c.component->as;
794               continue;
795
796             case REF_SUBSTRING:
797               continue;
798
799             case REF_ARRAY:
800               {
801                 switch (ref->u.ar.type)
802                   {
803                   case AR_ELEMENT:
804                   case AR_SECTION:
805                   case AR_UNKNOWN:
806                     as = NULL;
807                     continue;
808
809                   case AR_FULL:
810                     break;
811                   }
812               }
813             }
814         }
815     }
816   else
817     as = NULL;
818
819   /* 13.14.53: Result value for LBOUND
820
821      Case (i): For an array section or for an array expression other than a
822                whole array or array structure component, LBOUND(ARRAY, DIM)
823                has the value 1.  For a whole array or array structure
824                component, LBOUND(ARRAY, DIM) has the value:
825                  (a) equal to the lower bound for subscript DIM of ARRAY if
826                      dimension DIM of ARRAY does not have extent zero
827                      or if ARRAY is an assumed-size array of rank DIM,
828               or (b) 1 otherwise.
829
830      13.14.113: Result value for UBOUND
831
832      Case (i): For an array section or for an array expression other than a
833                whole array or array structure component, UBOUND(ARRAY, DIM)
834                has the value equal to the number of elements in the given
835                dimension; otherwise, it has a value equal to the upper bound
836                for subscript DIM of ARRAY if dimension DIM of ARRAY does
837                not have size zero and has value zero if dimension DIM has
838                size zero.  */
839
840   if (as)
841     {
842       tree stride = gfc_conv_descriptor_stride (desc, bound);
843       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
844       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
845       cond3 = fold_build2 (GT_EXPR, boolean_type_node, stride,
846                            gfc_index_zero_node);
847
848       if (upper)
849         {
850           cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
851           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond2);
852
853           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
854                                   ubound, gfc_index_zero_node);
855         }
856       else
857         {
858           if (as->type == AS_ASSUMED_SIZE)
859             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
860                                 build_int_cst (TREE_TYPE (bound),
861                                                arg->expr->rank));
862           else
863             cond = boolean_false_node;
864
865           cond1 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
866           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond1, cond2);
867
868           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
869
870           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
871                                   lbound, gfc_index_one_node);
872         }
873     }
874   else
875     {
876       if (upper)
877         {
878           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
879           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
880                                   gfc_index_one_node);
881         }
882       else
883         se->expr = gfc_index_one_node;
884     }
885
886   type = gfc_typenode_for_spec (&expr->ts);
887   se->expr = convert (type, se->expr);
888 }
889
890
891 static void
892 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
893 {
894   tree args;
895   tree val;
896   int n;
897
898   args = gfc_conv_intrinsic_function_args (se, expr);
899   gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
900   val = TREE_VALUE (args);
901
902   switch (expr->value.function.actual->expr->ts.type)
903     {
904     case BT_INTEGER:
905     case BT_REAL:
906       se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
907       break;
908
909     case BT_COMPLEX:
910       switch (expr->ts.kind)
911         {
912         case 4:
913           n = BUILT_IN_CABSF;
914           break;
915         case 8:
916           n = BUILT_IN_CABS;
917           break;
918         case 10:
919         case 16:
920           n = BUILT_IN_CABSL;
921           break;
922         default:
923           gcc_unreachable ();
924         }
925       se->expr = build_function_call_expr (built_in_decls[n], args);
926       break;
927
928     default:
929       gcc_unreachable ();
930     }
931 }
932
933
934 /* Create a complex value from one or two real components.  */
935
936 static void
937 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
938 {
939   tree arg;
940   tree real;
941   tree imag;
942   tree type;
943
944   type = gfc_typenode_for_spec (&expr->ts);
945   arg = gfc_conv_intrinsic_function_args (se, expr);
946   real = convert (TREE_TYPE (type), TREE_VALUE (arg));
947   if (both)
948     imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
949   else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
950     {
951       arg = TREE_VALUE (arg);
952       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
953       imag = convert (TREE_TYPE (type), imag);
954     }
955   else
956     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
957
958   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
959 }
960
961 /* Remainder function MOD(A, P) = A - INT(A / P) * P
962                       MODULO(A, P) = A - FLOOR (A / P) * P  */
963 /* TODO: MOD(x, 0)  */
964
965 static void
966 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
967 {
968   tree arg;
969   tree arg2;
970   tree type;
971   tree itype;
972   tree tmp;
973   tree test;
974   tree test2;
975   mpfr_t huge;
976   int n, ikind;
977
978   arg = gfc_conv_intrinsic_function_args (se, expr);
979   arg2 = TREE_VALUE (TREE_CHAIN (arg));
980   arg = TREE_VALUE (arg);
981   type = TREE_TYPE (arg);
982
983   switch (expr->ts.type)
984     {
985     case BT_INTEGER:
986       /* Integer case is easy, we've got a builtin op.  */
987       if (modulo)
988        se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
989       else
990        se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
991       break;
992
993     case BT_REAL:
994       /* Real values we have to do the hard way.  */
995       arg = gfc_evaluate_now (arg, &se->pre);
996       arg2 = gfc_evaluate_now (arg2, &se->pre);
997
998       tmp = build2 (RDIV_EXPR, type, arg, arg2);
999       /* Test if the value is too large to handle sensibly.  */
1000       gfc_set_model_kind (expr->ts.kind);
1001       mpfr_init (huge);
1002       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1003       ikind = expr->ts.kind;
1004       if (n < 0)
1005         {
1006           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1007           ikind = gfc_max_integer_kind;
1008         }
1009       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1010       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1011       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
1012
1013       mpfr_neg (huge, huge, GFC_RND_MODE);
1014       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1015       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
1016       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1017
1018       itype = gfc_get_int_type (ikind);
1019       if (modulo)
1020        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
1021       else
1022        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
1023       tmp = convert (type, tmp);
1024       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
1025       tmp = build2 (MULT_EXPR, type, tmp, arg2);
1026       se->expr = build2 (MINUS_EXPR, type, arg, tmp);
1027       mpfr_clear (huge);
1028       break;
1029
1030     default:
1031       gcc_unreachable ();
1032     }
1033 }
1034
1035 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1036
1037 static void
1038 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1039 {
1040   tree arg;
1041   tree arg2;
1042   tree val;
1043   tree tmp;
1044   tree type;
1045   tree zero;
1046
1047   arg = gfc_conv_intrinsic_function_args (se, expr);
1048   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1049   arg = TREE_VALUE (arg);
1050   type = TREE_TYPE (arg);
1051
1052   val = build2 (MINUS_EXPR, type, arg, arg2);
1053   val = gfc_evaluate_now (val, &se->pre);
1054
1055   zero = gfc_build_const (type, integer_zero_node);
1056   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
1057   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
1058 }
1059
1060
1061 /* SIGN(A, B) is absolute value of A times sign of B.
1062    The real value versions use library functions to ensure the correct
1063    handling of negative zero.  Integer case implemented as:
1064    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
1065   */
1066
1067 static void
1068 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1069 {
1070   tree tmp;
1071   tree arg;
1072   tree arg2;
1073   tree type;
1074   tree zero;
1075   tree testa;
1076   tree testb;
1077
1078
1079   arg = gfc_conv_intrinsic_function_args (se, expr);
1080   if (expr->ts.type == BT_REAL)
1081     {
1082       switch (expr->ts.kind)
1083         {
1084         case 4:
1085           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1086           break;
1087         case 8:
1088           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1089           break;
1090         case 10:
1091         case 16:
1092           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1093           break;
1094         default:
1095           gcc_unreachable ();
1096         }
1097       se->expr = build_function_call_expr (tmp, arg);
1098       return;
1099     }
1100
1101   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1102   arg = TREE_VALUE (arg);
1103   type = TREE_TYPE (arg);
1104   zero = gfc_build_const (type, integer_zero_node);
1105
1106   testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
1107   testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
1108   tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
1109   se->expr = fold_build3 (COND_EXPR, type, tmp,
1110                           build1 (NEGATE_EXPR, type, arg), arg);
1111 }
1112
1113
1114 /* Test for the presence of an optional argument.  */
1115
1116 static void
1117 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1118 {
1119   gfc_expr *arg;
1120
1121   arg = expr->value.function.actual->expr;
1122   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1123   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1124   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1125 }
1126
1127
1128 /* Calculate the double precision product of two single precision values.  */
1129
1130 static void
1131 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1132 {
1133   tree arg;
1134   tree arg2;
1135   tree type;
1136
1137   arg = gfc_conv_intrinsic_function_args (se, expr);
1138   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1139   arg = TREE_VALUE (arg);
1140
1141   /* Convert the args to double precision before multiplying.  */
1142   type = gfc_typenode_for_spec (&expr->ts);
1143   arg = convert (type, arg);
1144   arg2 = convert (type, arg2);
1145   se->expr = build2 (MULT_EXPR, type, arg, arg2);
1146 }
1147
1148
1149 /* Return a length one character string containing an ascii character.  */
1150
1151 static void
1152 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1153 {
1154   tree arg;
1155   tree var;
1156   tree type;
1157
1158   arg = gfc_conv_intrinsic_function_args (se, expr);
1159   arg = TREE_VALUE (arg);
1160
1161   /* We currently don't support character types != 1.  */
1162   gcc_assert (expr->ts.kind == 1);
1163   type = gfc_character1_type_node;
1164   var = gfc_create_var (type, "char");
1165
1166   arg = convert (type, arg);
1167   gfc_add_modify_expr (&se->pre, var, arg);
1168   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1169   se->string_length = integer_one_node;
1170 }
1171
1172
1173 static void
1174 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1175 {
1176   tree var;
1177   tree len;
1178   tree tmp;
1179   tree arglist;
1180   tree type;
1181   tree cond;
1182   tree gfc_int8_type_node = gfc_get_int_type (8);
1183
1184   type = build_pointer_type (gfc_character1_type_node);
1185   var = gfc_create_var (type, "pstr");
1186   len = gfc_create_var (gfc_int8_type_node, "len");
1187
1188   tmp = gfc_conv_intrinsic_function_args (se, expr);
1189   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1190   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1191   arglist = chainon (arglist, tmp);
1192
1193   tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
1194   gfc_add_expr_to_block (&se->pre, tmp);
1195
1196   /* Free the temporary afterwards, if necessary.  */
1197   cond = build2 (GT_EXPR, boolean_type_node, len,
1198                  build_int_cst (TREE_TYPE (len), 0));
1199   arglist = gfc_chainon_list (NULL_TREE, var);
1200   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1201   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1202   gfc_add_expr_to_block (&se->post, tmp);
1203
1204   se->expr = var;
1205   se->string_length = len;
1206 }
1207
1208
1209 static void
1210 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1211 {
1212   tree var;
1213   tree len;
1214   tree tmp;
1215   tree arglist;
1216   tree type;
1217   tree cond;
1218   tree gfc_int4_type_node = gfc_get_int_type (4);
1219
1220   type = build_pointer_type (gfc_character1_type_node);
1221   var = gfc_create_var (type, "pstr");
1222   len = gfc_create_var (gfc_int4_type_node, "len");
1223
1224   tmp = gfc_conv_intrinsic_function_args (se, expr);
1225   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1226   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1227   arglist = chainon (arglist, tmp);
1228
1229   tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
1230   gfc_add_expr_to_block (&se->pre, tmp);
1231
1232   /* Free the temporary afterwards, if necessary.  */
1233   cond = build2 (GT_EXPR, boolean_type_node, len,
1234                  build_int_cst (TREE_TYPE (len), 0));
1235   arglist = gfc_chainon_list (NULL_TREE, var);
1236   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1237   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1238   gfc_add_expr_to_block (&se->post, tmp);
1239
1240   se->expr = var;
1241   se->string_length = len;
1242 }
1243
1244
1245 /* Return a character string containing the tty name.  */
1246
1247 static void
1248 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1249 {
1250   tree var;
1251   tree len;
1252   tree tmp;
1253   tree arglist;
1254   tree type;
1255   tree cond;
1256   tree gfc_int4_type_node = gfc_get_int_type (4);
1257
1258   type = build_pointer_type (gfc_character1_type_node);
1259   var = gfc_create_var (type, "pstr");
1260   len = gfc_create_var (gfc_int4_type_node, "len");
1261
1262   tmp = gfc_conv_intrinsic_function_args (se, expr);
1263   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1264   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1265   arglist = chainon (arglist, tmp);
1266
1267   tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
1268   gfc_add_expr_to_block (&se->pre, tmp);
1269
1270   /* Free the temporary afterwards, if necessary.  */
1271   cond = build2 (GT_EXPR, boolean_type_node, len,
1272                  build_int_cst (TREE_TYPE (len), 0));
1273   arglist = gfc_chainon_list (NULL_TREE, var);
1274   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1275   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1276   gfc_add_expr_to_block (&se->post, tmp);
1277
1278   se->expr = var;
1279   se->string_length = len;
1280 }
1281
1282
1283 /* Get the minimum/maximum value of all the parameters.
1284     minmax (a1, a2, a3, ...)
1285     {
1286       if (a2 .op. a1)
1287         mvar = a2;
1288       else
1289         mvar = a1;
1290       if (a3 .op. mvar)
1291         mvar = a3;
1292       ...
1293       return mvar
1294     }
1295  */
1296
1297 /* TODO: Mismatching types can occur when specific names are used.
1298    These should be handled during resolution.  */
1299 static void
1300 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1301 {
1302   tree limit;
1303   tree tmp;
1304   tree mvar;
1305   tree val;
1306   tree thencase;
1307   tree elsecase;
1308   tree arg;
1309   tree type;
1310
1311   arg = gfc_conv_intrinsic_function_args (se, expr);
1312   type = gfc_typenode_for_spec (&expr->ts);
1313
1314   limit = TREE_VALUE (arg);
1315   if (TREE_TYPE (limit) != type)
1316     limit = convert (type, limit);
1317   /* Only evaluate the argument once.  */
1318   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1319     limit = gfc_evaluate_now(limit, &se->pre);
1320
1321   mvar = gfc_create_var (type, "M");
1322   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1323   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1324     {
1325       val = TREE_VALUE (arg);
1326       if (TREE_TYPE (val) != type)
1327         val = convert (type, val);
1328
1329       /* Only evaluate the argument once.  */
1330       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1331         val = gfc_evaluate_now(val, &se->pre);
1332
1333       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1334
1335       tmp = build2 (op, boolean_type_node, val, limit);
1336       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1337       gfc_add_expr_to_block (&se->pre, tmp);
1338       elsecase = build_empty_stmt ();
1339       limit = mvar;
1340     }
1341   se->expr = mvar;
1342 }
1343
1344
1345 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1346    has the generic name.  */
1347
1348 static gfc_symbol *
1349 gfc_get_symbol_for_expr (gfc_expr * expr)
1350 {
1351   gfc_symbol *sym;
1352
1353   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1354   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1355   sym = gfc_new_symbol (expr->value.function.name, NULL);
1356
1357   sym->ts = expr->ts;
1358   sym->attr.external = 1;
1359   sym->attr.function = 1;
1360   sym->attr.always_explicit = 1;
1361   sym->attr.proc = PROC_INTRINSIC;
1362   sym->attr.flavor = FL_PROCEDURE;
1363   sym->result = sym;
1364   if (expr->rank > 0)
1365     {
1366       sym->attr.dimension = 1;
1367       sym->as = gfc_get_array_spec ();
1368       sym->as->type = AS_ASSUMED_SHAPE;
1369       sym->as->rank = expr->rank;
1370     }
1371
1372   /* TODO: proper argument lists for external intrinsics.  */
1373   return sym;
1374 }
1375
1376 /* Generate a call to an external intrinsic function.  */
1377 static void
1378 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1379 {
1380   gfc_symbol *sym;
1381   tree append_args;
1382
1383   gcc_assert (!se->ss || se->ss->expr == expr);
1384
1385   if (se->ss)
1386     gcc_assert (expr->rank > 0);
1387   else
1388     gcc_assert (expr->rank == 0);
1389
1390   sym = gfc_get_symbol_for_expr (expr);
1391
1392   /* Calls to libgfortran_matmul need to be appended special arguments,
1393      to be able to call the BLAS ?gemm functions if required and possible.  */
1394   append_args = NULL_TREE;
1395   if (expr->value.function.isym->generic_id == GFC_ISYM_MATMUL
1396       && sym->ts.type != BT_LOGICAL)
1397     {
1398       tree cint = gfc_get_int_type (gfc_c_int_kind);
1399
1400       if (gfc_option.flag_external_blas
1401           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1402           && (sym->ts.kind == gfc_default_real_kind
1403               || sym->ts.kind == gfc_default_double_kind))
1404         {
1405           tree gemm_fndecl;
1406
1407           if (sym->ts.type == BT_REAL)
1408             {
1409               if (sym->ts.kind == gfc_default_real_kind)
1410                 gemm_fndecl = gfor_fndecl_sgemm;
1411               else
1412                 gemm_fndecl = gfor_fndecl_dgemm;
1413             }
1414           else
1415             {
1416               if (sym->ts.kind == gfc_default_real_kind)
1417                 gemm_fndecl = gfor_fndecl_cgemm;
1418               else
1419                 gemm_fndecl = gfor_fndecl_zgemm;
1420             }
1421
1422           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1423           append_args = gfc_chainon_list
1424                           (append_args, build_int_cst
1425                                           (cint, gfc_option.blas_matmul_limit));
1426           append_args = gfc_chainon_list (append_args,
1427                                           gfc_build_addr_expr (NULL_TREE,
1428                                                                gemm_fndecl));
1429         }
1430       else
1431         {
1432           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1433           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1434           append_args = gfc_chainon_list (append_args, null_pointer_node);
1435         }
1436     }
1437
1438   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1439   gfc_free (sym);
1440 }
1441
1442 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1443    Implemented as
1444     any(a)
1445     {
1446       forall (i=...)
1447         if (a[i] != 0)
1448           return 1
1449       end forall
1450       return 0
1451     }
1452     all(a)
1453     {
1454       forall (i=...)
1455         if (a[i] == 0)
1456           return 0
1457       end forall
1458       return 1
1459     }
1460  */
1461 static void
1462 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1463 {
1464   tree resvar;
1465   stmtblock_t block;
1466   stmtblock_t body;
1467   tree type;
1468   tree tmp;
1469   tree found;
1470   gfc_loopinfo loop;
1471   gfc_actual_arglist *actual;
1472   gfc_ss *arrayss;
1473   gfc_se arrayse;
1474   tree exit_label;
1475
1476   if (se->ss)
1477     {
1478       gfc_conv_intrinsic_funcall (se, expr);
1479       return;
1480     }
1481
1482   actual = expr->value.function.actual;
1483   type = gfc_typenode_for_spec (&expr->ts);
1484   /* Initialize the result.  */
1485   resvar = gfc_create_var (type, "test");
1486   if (op == EQ_EXPR)
1487     tmp = convert (type, boolean_true_node);
1488   else
1489     tmp = convert (type, boolean_false_node);
1490   gfc_add_modify_expr (&se->pre, resvar, tmp);
1491
1492   /* Walk the arguments.  */
1493   arrayss = gfc_walk_expr (actual->expr);
1494   gcc_assert (arrayss != gfc_ss_terminator);
1495
1496   /* Initialize the scalarizer.  */
1497   gfc_init_loopinfo (&loop);
1498   exit_label = gfc_build_label_decl (NULL_TREE);
1499   TREE_USED (exit_label) = 1;
1500   gfc_add_ss_to_loop (&loop, arrayss);
1501
1502   /* Initialize the loop.  */
1503   gfc_conv_ss_startstride (&loop);
1504   gfc_conv_loop_setup (&loop);
1505
1506   gfc_mark_ss_chain_used (arrayss, 1);
1507   /* Generate the loop body.  */
1508   gfc_start_scalarized_body (&loop, &body);
1509
1510   /* If the condition matches then set the return value.  */
1511   gfc_start_block (&block);
1512   if (op == EQ_EXPR)
1513     tmp = convert (type, boolean_false_node);
1514   else
1515     tmp = convert (type, boolean_true_node);
1516   gfc_add_modify_expr (&block, resvar, tmp);
1517
1518   /* And break out of the loop.  */
1519   tmp = build1_v (GOTO_EXPR, exit_label);
1520   gfc_add_expr_to_block (&block, tmp);
1521
1522   found = gfc_finish_block (&block);
1523
1524   /* Check this element.  */
1525   gfc_init_se (&arrayse, NULL);
1526   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1527   arrayse.ss = arrayss;
1528   gfc_conv_expr_val (&arrayse, actual->expr);
1529
1530   gfc_add_block_to_block (&body, &arrayse.pre);
1531   tmp = build2 (op, boolean_type_node, arrayse.expr,
1532                 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1533   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1534   gfc_add_expr_to_block (&body, tmp);
1535   gfc_add_block_to_block (&body, &arrayse.post);
1536
1537   gfc_trans_scalarizing_loops (&loop, &body);
1538
1539   /* Add the exit label.  */
1540   tmp = build1_v (LABEL_EXPR, exit_label);
1541   gfc_add_expr_to_block (&loop.pre, tmp);
1542
1543   gfc_add_block_to_block (&se->pre, &loop.pre);
1544   gfc_add_block_to_block (&se->pre, &loop.post);
1545   gfc_cleanup_loop (&loop);
1546
1547   se->expr = resvar;
1548 }
1549
1550 /* COUNT(A) = Number of true elements in A.  */
1551 static void
1552 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1553 {
1554   tree resvar;
1555   tree type;
1556   stmtblock_t body;
1557   tree tmp;
1558   gfc_loopinfo loop;
1559   gfc_actual_arglist *actual;
1560   gfc_ss *arrayss;
1561   gfc_se arrayse;
1562
1563   if (se->ss)
1564     {
1565       gfc_conv_intrinsic_funcall (se, expr);
1566       return;
1567     }
1568
1569   actual = expr->value.function.actual;
1570
1571   type = gfc_typenode_for_spec (&expr->ts);
1572   /* Initialize the result.  */
1573   resvar = gfc_create_var (type, "count");
1574   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1575
1576   /* Walk the arguments.  */
1577   arrayss = gfc_walk_expr (actual->expr);
1578   gcc_assert (arrayss != gfc_ss_terminator);
1579
1580   /* Initialize the scalarizer.  */
1581   gfc_init_loopinfo (&loop);
1582   gfc_add_ss_to_loop (&loop, arrayss);
1583
1584   /* Initialize the loop.  */
1585   gfc_conv_ss_startstride (&loop);
1586   gfc_conv_loop_setup (&loop);
1587
1588   gfc_mark_ss_chain_used (arrayss, 1);
1589   /* Generate the loop body.  */
1590   gfc_start_scalarized_body (&loop, &body);
1591
1592   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1593                 build_int_cst (TREE_TYPE (resvar), 1));
1594   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1595
1596   gfc_init_se (&arrayse, NULL);
1597   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1598   arrayse.ss = arrayss;
1599   gfc_conv_expr_val (&arrayse, actual->expr);
1600   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1601
1602   gfc_add_block_to_block (&body, &arrayse.pre);
1603   gfc_add_expr_to_block (&body, tmp);
1604   gfc_add_block_to_block (&body, &arrayse.post);
1605
1606   gfc_trans_scalarizing_loops (&loop, &body);
1607
1608   gfc_add_block_to_block (&se->pre, &loop.pre);
1609   gfc_add_block_to_block (&se->pre, &loop.post);
1610   gfc_cleanup_loop (&loop);
1611
1612   se->expr = resvar;
1613 }
1614
1615 /* Inline implementation of the sum and product intrinsics.  */
1616 static void
1617 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1618 {
1619   tree resvar;
1620   tree type;
1621   stmtblock_t body;
1622   stmtblock_t block;
1623   tree tmp;
1624   gfc_loopinfo loop;
1625   gfc_actual_arglist *actual;
1626   gfc_ss *arrayss;
1627   gfc_ss *maskss;
1628   gfc_se arrayse;
1629   gfc_se maskse;
1630   gfc_expr *arrayexpr;
1631   gfc_expr *maskexpr;
1632
1633   if (se->ss)
1634     {
1635       gfc_conv_intrinsic_funcall (se, expr);
1636       return;
1637     }
1638
1639   type = gfc_typenode_for_spec (&expr->ts);
1640   /* Initialize the result.  */
1641   resvar = gfc_create_var (type, "val");
1642   if (op == PLUS_EXPR)
1643     tmp = gfc_build_const (type, integer_zero_node);
1644   else
1645     tmp = gfc_build_const (type, integer_one_node);
1646
1647   gfc_add_modify_expr (&se->pre, resvar, tmp);
1648
1649   /* Walk the arguments.  */
1650   actual = expr->value.function.actual;
1651   arrayexpr = actual->expr;
1652   arrayss = gfc_walk_expr (arrayexpr);
1653   gcc_assert (arrayss != gfc_ss_terminator);
1654
1655   actual = actual->next->next;
1656   gcc_assert (actual);
1657   maskexpr = actual->expr;
1658   if (maskexpr && maskexpr->rank != 0)
1659     {
1660       maskss = gfc_walk_expr (maskexpr);
1661       gcc_assert (maskss != gfc_ss_terminator);
1662     }
1663   else
1664     maskss = NULL;
1665
1666   /* Initialize the scalarizer.  */
1667   gfc_init_loopinfo (&loop);
1668   gfc_add_ss_to_loop (&loop, arrayss);
1669   if (maskss)
1670     gfc_add_ss_to_loop (&loop, maskss);
1671
1672   /* Initialize the loop.  */
1673   gfc_conv_ss_startstride (&loop);
1674   gfc_conv_loop_setup (&loop);
1675
1676   gfc_mark_ss_chain_used (arrayss, 1);
1677   if (maskss)
1678     gfc_mark_ss_chain_used (maskss, 1);
1679   /* Generate the loop body.  */
1680   gfc_start_scalarized_body (&loop, &body);
1681
1682   /* If we have a mask, only add this element if the mask is set.  */
1683   if (maskss)
1684     {
1685       gfc_init_se (&maskse, NULL);
1686       gfc_copy_loopinfo_to_se (&maskse, &loop);
1687       maskse.ss = maskss;
1688       gfc_conv_expr_val (&maskse, maskexpr);
1689       gfc_add_block_to_block (&body, &maskse.pre);
1690
1691       gfc_start_block (&block);
1692     }
1693   else
1694     gfc_init_block (&block);
1695
1696   /* Do the actual summation/product.  */
1697   gfc_init_se (&arrayse, NULL);
1698   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1699   arrayse.ss = arrayss;
1700   gfc_conv_expr_val (&arrayse, arrayexpr);
1701   gfc_add_block_to_block (&block, &arrayse.pre);
1702
1703   tmp = build2 (op, type, resvar, arrayse.expr);
1704   gfc_add_modify_expr (&block, resvar, tmp);
1705   gfc_add_block_to_block (&block, &arrayse.post);
1706
1707   if (maskss)
1708     {
1709       /* We enclose the above in if (mask) {...} .  */
1710       tmp = gfc_finish_block (&block);
1711
1712       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1713     }
1714   else
1715     tmp = gfc_finish_block (&block);
1716   gfc_add_expr_to_block (&body, tmp);
1717
1718   gfc_trans_scalarizing_loops (&loop, &body);
1719
1720   /* For a scalar mask, enclose the loop in an if statement.  */
1721   if (maskexpr && maskss == NULL)
1722     {
1723       gfc_init_se (&maskse, NULL);
1724       gfc_conv_expr_val (&maskse, maskexpr);
1725       gfc_init_block (&block);
1726       gfc_add_block_to_block (&block, &loop.pre);
1727       gfc_add_block_to_block (&block, &loop.post);
1728       tmp = gfc_finish_block (&block);
1729
1730       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1731       gfc_add_expr_to_block (&block, tmp);
1732       gfc_add_block_to_block (&se->pre, &block);
1733     }
1734   else
1735     {
1736       gfc_add_block_to_block (&se->pre, &loop.pre);
1737       gfc_add_block_to_block (&se->pre, &loop.post);
1738     }
1739
1740   gfc_cleanup_loop (&loop);
1741
1742   se->expr = resvar;
1743 }
1744
1745
1746 /* Inline implementation of the dot_product intrinsic. This function
1747    is based on gfc_conv_intrinsic_arith (the previous function).  */
1748 static void
1749 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1750 {
1751   tree resvar;
1752   tree type;
1753   stmtblock_t body;
1754   stmtblock_t block;
1755   tree tmp;
1756   gfc_loopinfo loop;
1757   gfc_actual_arglist *actual;
1758   gfc_ss *arrayss1, *arrayss2;
1759   gfc_se arrayse1, arrayse2;
1760   gfc_expr *arrayexpr1, *arrayexpr2;
1761
1762   type = gfc_typenode_for_spec (&expr->ts);
1763
1764   /* Initialize the result.  */
1765   resvar = gfc_create_var (type, "val");
1766   if (expr->ts.type == BT_LOGICAL)
1767     tmp = convert (type, integer_zero_node);
1768   else
1769     tmp = gfc_build_const (type, integer_zero_node);
1770
1771   gfc_add_modify_expr (&se->pre, resvar, tmp);
1772
1773   /* Walk argument #1.  */
1774   actual = expr->value.function.actual;
1775   arrayexpr1 = actual->expr;
1776   arrayss1 = gfc_walk_expr (arrayexpr1);
1777   gcc_assert (arrayss1 != gfc_ss_terminator);
1778
1779   /* Walk argument #2.  */
1780   actual = actual->next;
1781   arrayexpr2 = actual->expr;
1782   arrayss2 = gfc_walk_expr (arrayexpr2);
1783   gcc_assert (arrayss2 != gfc_ss_terminator);
1784
1785   /* Initialize the scalarizer.  */
1786   gfc_init_loopinfo (&loop);
1787   gfc_add_ss_to_loop (&loop, arrayss1);
1788   gfc_add_ss_to_loop (&loop, arrayss2);
1789
1790   /* Initialize the loop.  */
1791   gfc_conv_ss_startstride (&loop);
1792   gfc_conv_loop_setup (&loop);
1793
1794   gfc_mark_ss_chain_used (arrayss1, 1);
1795   gfc_mark_ss_chain_used (arrayss2, 1);
1796
1797   /* Generate the loop body.  */
1798   gfc_start_scalarized_body (&loop, &body);
1799   gfc_init_block (&block);
1800
1801   /* Make the tree expression for [conjg(]array1[)].  */
1802   gfc_init_se (&arrayse1, NULL);
1803   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
1804   arrayse1.ss = arrayss1;
1805   gfc_conv_expr_val (&arrayse1, arrayexpr1);
1806   if (expr->ts.type == BT_COMPLEX)
1807     arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
1808   gfc_add_block_to_block (&block, &arrayse1.pre);
1809
1810   /* Make the tree expression for array2.  */
1811   gfc_init_se (&arrayse2, NULL);
1812   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
1813   arrayse2.ss = arrayss2;
1814   gfc_conv_expr_val (&arrayse2, arrayexpr2);
1815   gfc_add_block_to_block (&block, &arrayse2.pre);
1816
1817   /* Do the actual product and sum.  */
1818   if (expr->ts.type == BT_LOGICAL)
1819     {
1820       tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
1821       tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
1822     }
1823   else
1824     {
1825       tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
1826       tmp = build2 (PLUS_EXPR, type, resvar, tmp);
1827     }
1828   gfc_add_modify_expr (&block, resvar, tmp);
1829
1830   /* Finish up the loop block and the loop.  */
1831   tmp = gfc_finish_block (&block);
1832   gfc_add_expr_to_block (&body, tmp);
1833
1834   gfc_trans_scalarizing_loops (&loop, &body);
1835   gfc_add_block_to_block (&se->pre, &loop.pre);
1836   gfc_add_block_to_block (&se->pre, &loop.post);
1837   gfc_cleanup_loop (&loop);
1838
1839   se->expr = resvar;
1840 }
1841
1842
1843 static void
1844 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1845 {
1846   stmtblock_t body;
1847   stmtblock_t block;
1848   stmtblock_t ifblock;
1849   stmtblock_t elseblock;
1850   tree limit;
1851   tree type;
1852   tree tmp;
1853   tree elsetmp;
1854   tree ifbody;
1855   gfc_loopinfo loop;
1856   gfc_actual_arglist *actual;
1857   gfc_ss *arrayss;
1858   gfc_ss *maskss;
1859   gfc_se arrayse;
1860   gfc_se maskse;
1861   gfc_expr *arrayexpr;
1862   gfc_expr *maskexpr;
1863   tree pos;
1864   int n;
1865
1866   if (se->ss)
1867     {
1868       gfc_conv_intrinsic_funcall (se, expr);
1869       return;
1870     }
1871
1872   /* Initialize the result.  */
1873   pos = gfc_create_var (gfc_array_index_type, "pos");
1874   type = gfc_typenode_for_spec (&expr->ts);
1875
1876   /* Walk the arguments.  */
1877   actual = expr->value.function.actual;
1878   arrayexpr = actual->expr;
1879   arrayss = gfc_walk_expr (arrayexpr);
1880   gcc_assert (arrayss != gfc_ss_terminator);
1881
1882   actual = actual->next->next;
1883   gcc_assert (actual);
1884   maskexpr = actual->expr;
1885   if (maskexpr && maskexpr->rank != 0)
1886     {
1887       maskss = gfc_walk_expr (maskexpr);
1888       gcc_assert (maskss != gfc_ss_terminator);
1889     }
1890   else
1891     maskss = NULL;
1892
1893   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1894   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1895   switch (arrayexpr->ts.type)
1896     {
1897     case BT_REAL:
1898       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1899       break;
1900
1901     case BT_INTEGER:
1902       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1903                                   arrayexpr->ts.kind);
1904       break;
1905
1906     default:
1907       gcc_unreachable ();
1908     }
1909
1910   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1911   if (op == GT_EXPR)
1912     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1913   gfc_add_modify_expr (&se->pre, limit, tmp);
1914
1915   /* Initialize the scalarizer.  */
1916   gfc_init_loopinfo (&loop);
1917   gfc_add_ss_to_loop (&loop, arrayss);
1918   if (maskss)
1919     gfc_add_ss_to_loop (&loop, maskss);
1920
1921   /* Initialize the loop.  */
1922   gfc_conv_ss_startstride (&loop);
1923   gfc_conv_loop_setup (&loop);
1924
1925   gcc_assert (loop.dimen == 1);
1926
1927   /* Initialize the position to zero, following Fortran 2003.  We are free
1928      to do this because Fortran 95 allows the result of an entirely false
1929      mask to be processor dependent.  */
1930   gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
1931
1932   gfc_mark_ss_chain_used (arrayss, 1);
1933   if (maskss)
1934     gfc_mark_ss_chain_used (maskss, 1);
1935   /* Generate the loop body.  */
1936   gfc_start_scalarized_body (&loop, &body);
1937
1938   /* If we have a mask, only check this element if the mask is set.  */
1939   if (maskss)
1940     {
1941       gfc_init_se (&maskse, NULL);
1942       gfc_copy_loopinfo_to_se (&maskse, &loop);
1943       maskse.ss = maskss;
1944       gfc_conv_expr_val (&maskse, maskexpr);
1945       gfc_add_block_to_block (&body, &maskse.pre);
1946
1947       gfc_start_block (&block);
1948     }
1949   else
1950     gfc_init_block (&block);
1951
1952   /* Compare with the current limit.  */
1953   gfc_init_se (&arrayse, NULL);
1954   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1955   arrayse.ss = arrayss;
1956   gfc_conv_expr_val (&arrayse, arrayexpr);
1957   gfc_add_block_to_block (&block, &arrayse.pre);
1958
1959   /* We do the following if this is a more extreme value.  */
1960   gfc_start_block (&ifblock);
1961
1962   /* Assign the value to the limit...  */
1963   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1964
1965   /* Remember where we are.  */
1966   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1967
1968   ifbody = gfc_finish_block (&ifblock);
1969
1970   /* If it is a more extreme value or pos is still zero.  */
1971   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
1972                   build2 (op, boolean_type_node, arrayse.expr, limit),
1973                   build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
1974   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1975   gfc_add_expr_to_block (&block, tmp);
1976
1977   if (maskss)
1978     {
1979       /* We enclose the above in if (mask) {...}.  */
1980       tmp = gfc_finish_block (&block);
1981
1982       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1983     }
1984   else
1985     tmp = gfc_finish_block (&block);
1986   gfc_add_expr_to_block (&body, tmp);
1987
1988   gfc_trans_scalarizing_loops (&loop, &body);
1989
1990   /* For a scalar mask, enclose the loop in an if statement.  */
1991   if (maskexpr && maskss == NULL)
1992     {
1993       gfc_init_se (&maskse, NULL);
1994       gfc_conv_expr_val (&maskse, maskexpr);
1995       gfc_init_block (&block);
1996       gfc_add_block_to_block (&block, &loop.pre);
1997       gfc_add_block_to_block (&block, &loop.post);
1998       tmp = gfc_finish_block (&block);
1999
2000       /* For the else part of the scalar mask, just initialize
2001          the pos variable the same way as above.  */
2002
2003       gfc_init_block (&elseblock);
2004       gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2005       elsetmp = gfc_finish_block (&elseblock);
2006
2007       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2008       gfc_add_expr_to_block (&block, tmp);
2009       gfc_add_block_to_block (&se->pre, &block);
2010     }
2011   else
2012     {
2013       gfc_add_block_to_block (&se->pre, &loop.pre);
2014       gfc_add_block_to_block (&se->pre, &loop.post);
2015     }
2016   gfc_cleanup_loop (&loop);
2017
2018   /* Return a value in the range 1..SIZE(array).  */
2019   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
2020                      gfc_index_one_node);
2021   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
2022   /* And convert to the required type.  */
2023   se->expr = convert (type, tmp);
2024 }
2025
2026 static void
2027 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2028 {
2029   tree limit;
2030   tree type;
2031   tree tmp;
2032   tree ifbody;
2033   stmtblock_t body;
2034   stmtblock_t block;
2035   gfc_loopinfo loop;
2036   gfc_actual_arglist *actual;
2037   gfc_ss *arrayss;
2038   gfc_ss *maskss;
2039   gfc_se arrayse;
2040   gfc_se maskse;
2041   gfc_expr *arrayexpr;
2042   gfc_expr *maskexpr;
2043   int n;
2044
2045   if (se->ss)
2046     {
2047       gfc_conv_intrinsic_funcall (se, expr);
2048       return;
2049     }
2050
2051   type = gfc_typenode_for_spec (&expr->ts);
2052   /* Initialize the result.  */
2053   limit = gfc_create_var (type, "limit");
2054   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2055   switch (expr->ts.type)
2056     {
2057     case BT_REAL:
2058       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2059       break;
2060
2061     case BT_INTEGER:
2062       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2063       break;
2064
2065     default:
2066       gcc_unreachable ();
2067     }
2068
2069   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
2070   if (op == GT_EXPR)
2071     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2072   gfc_add_modify_expr (&se->pre, limit, tmp);
2073
2074   /* Walk the arguments.  */
2075   actual = expr->value.function.actual;
2076   arrayexpr = actual->expr;
2077   arrayss = gfc_walk_expr (arrayexpr);
2078   gcc_assert (arrayss != gfc_ss_terminator);
2079
2080   actual = actual->next->next;
2081   gcc_assert (actual);
2082   maskexpr = actual->expr;
2083   if (maskexpr && maskexpr->rank != 0)
2084     {
2085       maskss = gfc_walk_expr (maskexpr);
2086       gcc_assert (maskss != gfc_ss_terminator);
2087     }
2088   else
2089     maskss = NULL;
2090
2091   /* Initialize the scalarizer.  */
2092   gfc_init_loopinfo (&loop);
2093   gfc_add_ss_to_loop (&loop, arrayss);
2094   if (maskss)
2095     gfc_add_ss_to_loop (&loop, maskss);
2096
2097   /* Initialize the loop.  */
2098   gfc_conv_ss_startstride (&loop);
2099   gfc_conv_loop_setup (&loop);
2100
2101   gfc_mark_ss_chain_used (arrayss, 1);
2102   if (maskss)
2103     gfc_mark_ss_chain_used (maskss, 1);
2104   /* Generate the loop body.  */
2105   gfc_start_scalarized_body (&loop, &body);
2106
2107   /* If we have a mask, only add this element if the mask is set.  */
2108   if (maskss)
2109     {
2110       gfc_init_se (&maskse, NULL);
2111       gfc_copy_loopinfo_to_se (&maskse, &loop);
2112       maskse.ss = maskss;
2113       gfc_conv_expr_val (&maskse, maskexpr);
2114       gfc_add_block_to_block (&body, &maskse.pre);
2115
2116       gfc_start_block (&block);
2117     }
2118   else
2119     gfc_init_block (&block);
2120
2121   /* Compare with the current limit.  */
2122   gfc_init_se (&arrayse, NULL);
2123   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2124   arrayse.ss = arrayss;
2125   gfc_conv_expr_val (&arrayse, arrayexpr);
2126   gfc_add_block_to_block (&block, &arrayse.pre);
2127
2128   /* Assign the value to the limit...  */
2129   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2130
2131   /* If it is a more extreme value.  */
2132   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
2133   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2134   gfc_add_expr_to_block (&block, tmp);
2135   gfc_add_block_to_block (&block, &arrayse.post);
2136
2137   tmp = gfc_finish_block (&block);
2138   if (maskss)
2139     /* We enclose the above in if (mask) {...}.  */
2140     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2141   gfc_add_expr_to_block (&body, tmp);
2142
2143   gfc_trans_scalarizing_loops (&loop, &body);
2144
2145   /* For a scalar mask, enclose the loop in an if statement.  */
2146   if (maskexpr && maskss == NULL)
2147     {
2148       gfc_init_se (&maskse, NULL);
2149       gfc_conv_expr_val (&maskse, maskexpr);
2150       gfc_init_block (&block);
2151       gfc_add_block_to_block (&block, &loop.pre);
2152       gfc_add_block_to_block (&block, &loop.post);
2153       tmp = gfc_finish_block (&block);
2154
2155       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2156       gfc_add_expr_to_block (&block, tmp);
2157       gfc_add_block_to_block (&se->pre, &block);
2158     }
2159   else
2160     {
2161       gfc_add_block_to_block (&se->pre, &loop.pre);
2162       gfc_add_block_to_block (&se->pre, &loop.post);
2163     }
2164
2165   gfc_cleanup_loop (&loop);
2166
2167   se->expr = limit;
2168 }
2169
2170 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2171 static void
2172 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2173 {
2174   tree arg;
2175   tree arg2;
2176   tree type;
2177   tree tmp;
2178
2179   arg = gfc_conv_intrinsic_function_args (se, expr);
2180   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2181   arg = TREE_VALUE (arg);
2182   type = TREE_TYPE (arg);
2183
2184   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2185   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
2186   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2187                      build_int_cst (type, 0));
2188   type = gfc_typenode_for_spec (&expr->ts);
2189   se->expr = convert (type, tmp);
2190 }
2191
2192 /* Generate code to perform the specified operation.  */
2193 static void
2194 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2195 {
2196   tree arg;
2197   tree arg2;
2198   tree type;
2199
2200   arg = gfc_conv_intrinsic_function_args (se, expr);
2201   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2202   arg = TREE_VALUE (arg);
2203   type = TREE_TYPE (arg);
2204
2205   se->expr = fold_build2 (op, type, arg, arg2);
2206 }
2207
2208 /* Bitwise not.  */
2209 static void
2210 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2211 {
2212   tree arg;
2213
2214   arg = gfc_conv_intrinsic_function_args (se, expr);
2215   arg = TREE_VALUE (arg);
2216
2217   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2218 }
2219
2220 /* Set or clear a single bit.  */
2221 static void
2222 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2223 {
2224   tree arg;
2225   tree arg2;
2226   tree type;
2227   tree tmp;
2228   int op;
2229
2230   arg = gfc_conv_intrinsic_function_args (se, expr);
2231   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2232   arg = TREE_VALUE (arg);
2233   type = TREE_TYPE (arg);
2234
2235   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2236   if (set)
2237     op = BIT_IOR_EXPR;
2238   else
2239     {
2240       op = BIT_AND_EXPR;
2241       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2242     }
2243   se->expr = fold_build2 (op, type, arg, tmp);
2244 }
2245
2246 /* Extract a sequence of bits.
2247     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2248 static void
2249 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2250 {
2251   tree arg;
2252   tree arg2;
2253   tree arg3;
2254   tree type;
2255   tree tmp;
2256   tree mask;
2257
2258   arg = gfc_conv_intrinsic_function_args (se, expr);
2259   arg2 = TREE_CHAIN (arg);
2260   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
2261   arg = TREE_VALUE (arg);
2262   arg2 = TREE_VALUE (arg2);
2263   type = TREE_TYPE (arg);
2264
2265   mask = build_int_cst (NULL_TREE, -1);
2266   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
2267   mask = build1 (BIT_NOT_EXPR, type, mask);
2268
2269   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
2270
2271   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2272 }
2273
2274 /* RSHIFT (I, SHIFT) = I >> SHIFT
2275    LSHIFT (I, SHIFT) = I << SHIFT  */
2276 static void
2277 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2278 {
2279   tree arg;
2280   tree arg2;
2281
2282   arg = gfc_conv_intrinsic_function_args (se, expr);
2283   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2284   arg = TREE_VALUE (arg);
2285
2286   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2287                           TREE_TYPE (arg), arg, arg2);
2288 }
2289
2290 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2291                         ? 0
2292                         : ((shift >= 0) ? i << shift : i >> -shift)
2293    where all shifts are logical shifts.  */
2294 static void
2295 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2296 {
2297   tree arg;
2298   tree arg2;
2299   tree type;
2300   tree utype;
2301   tree tmp;
2302   tree width;
2303   tree num_bits;
2304   tree cond;
2305   tree lshift;
2306   tree rshift;
2307
2308   arg = gfc_conv_intrinsic_function_args (se, expr);
2309   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2310   arg = TREE_VALUE (arg);
2311   type = TREE_TYPE (arg);
2312   utype = gfc_unsigned_type (type);
2313
2314   width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
2315
2316   /* Left shift if positive.  */
2317   lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
2318
2319   /* Right shift if negative.
2320      We convert to an unsigned type because we want a logical shift.
2321      The standard doesn't define the case of shifting negative
2322      numbers, and we try to be compatible with other compilers, most
2323      notably g77, here.  */
2324   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype, 
2325                                        convert (utype, arg), width));
2326
2327   tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
2328                      build_int_cst (TREE_TYPE (arg2), 0));
2329   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2330
2331   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2332      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2333      special case.  */
2334   num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
2335   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2336
2337   se->expr = fold_build3 (COND_EXPR, type, cond,
2338                           build_int_cst (type, 0), tmp);
2339 }
2340
2341 /* Circular shift.  AKA rotate or barrel shift.  */
2342 static void
2343 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2344 {
2345   tree arg;
2346   tree arg2;
2347   tree arg3;
2348   tree type;
2349   tree tmp;
2350   tree lrot;
2351   tree rrot;
2352   tree zero;
2353
2354   arg = gfc_conv_intrinsic_function_args (se, expr);
2355   arg2 = TREE_CHAIN (arg);
2356   arg3 = TREE_CHAIN (arg2);
2357   if (arg3)
2358     {
2359       /* Use a library function for the 3 parameter version.  */
2360       tree int4type = gfc_get_int_type (4);
2361
2362       type = TREE_TYPE (TREE_VALUE (arg));
2363       /* We convert the first argument to at least 4 bytes, and
2364          convert back afterwards.  This removes the need for library
2365          functions for all argument sizes, and function will be
2366          aligned to at least 32 bits, so there's no loss.  */
2367       if (expr->ts.kind < 4)
2368         {
2369           tmp = convert (int4type, TREE_VALUE (arg));
2370           TREE_VALUE (arg) = tmp;
2371         }
2372       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2373          need loads of library  functions.  They cannot have values >
2374          BIT_SIZE (I) so the conversion is safe.  */
2375       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
2376       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
2377
2378       switch (expr->ts.kind)
2379         {
2380         case 1:
2381         case 2:
2382         case 4:
2383           tmp = gfor_fndecl_math_ishftc4;
2384           break;
2385         case 8:
2386           tmp = gfor_fndecl_math_ishftc8;
2387           break;
2388         case 16:
2389           tmp = gfor_fndecl_math_ishftc16;
2390           break;
2391         default:
2392           gcc_unreachable ();
2393         }
2394       se->expr = build_function_call_expr (tmp, arg);
2395       /* Convert the result back to the original type, if we extended
2396          the first argument's width above.  */
2397       if (expr->ts.kind < 4)
2398         se->expr = convert (type, se->expr);
2399
2400       return;
2401     }
2402   arg = TREE_VALUE (arg);
2403   arg2 = TREE_VALUE (arg2);
2404   type = TREE_TYPE (arg);
2405
2406   /* Rotate left if positive.  */
2407   lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
2408
2409   /* Rotate right if negative.  */
2410   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
2411   rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
2412
2413   zero = build_int_cst (TREE_TYPE (arg2), 0);
2414   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
2415   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2416
2417   /* Do nothing if shift == 0.  */
2418   tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
2419   se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
2420 }
2421
2422 /* The length of a character string.  */
2423 static void
2424 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2425 {
2426   tree len;
2427   tree type;
2428   tree decl;
2429   gfc_symbol *sym;
2430   gfc_se argse;
2431   gfc_expr *arg;
2432
2433   gcc_assert (!se->ss);
2434
2435   arg = expr->value.function.actual->expr;
2436
2437   type = gfc_typenode_for_spec (&expr->ts);
2438   switch (arg->expr_type)
2439     {
2440     case EXPR_CONSTANT:
2441       len = build_int_cst (NULL_TREE, arg->value.character.length);
2442       break;
2443
2444     case EXPR_ARRAY:
2445       /* Obtain the string length from the function used by
2446          trans-array.c(gfc_trans_array_constructor).  */
2447       len = NULL_TREE;
2448       get_array_ctor_strlen (arg->value.constructor, &len);
2449       break;
2450
2451     default:
2452         if (arg->expr_type == EXPR_VARIABLE
2453             && (arg->ref == NULL || (arg->ref->next == NULL
2454                                      && arg->ref->type == REF_ARRAY)))
2455           {
2456             /* This doesn't catch all cases.
2457                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2458                and the surrounding thread.  */
2459             sym = arg->symtree->n.sym;
2460             decl = gfc_get_symbol_decl (sym);
2461             if (decl == current_function_decl && sym->attr.function
2462                 && (sym->result == sym))
2463               decl = gfc_get_fake_result_decl (sym, 0);
2464
2465             len = sym->ts.cl->backend_decl;
2466             gcc_assert (len);
2467           }
2468         else
2469           {
2470             /* Anybody stupid enough to do this deserves inefficient code.  */
2471             gfc_init_se (&argse, se);
2472             gfc_conv_expr (&argse, arg);
2473             gfc_add_block_to_block (&se->pre, &argse.pre);
2474             gfc_add_block_to_block (&se->post, &argse.post);
2475             len = argse.string_length;
2476         }
2477       break;
2478     }
2479   se->expr = convert (type, len);
2480 }
2481
2482 /* The length of a character string not including trailing blanks.  */
2483 static void
2484 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2485 {
2486   tree args;
2487   tree type;
2488
2489   args = gfc_conv_intrinsic_function_args (se, expr);
2490   type = gfc_typenode_for_spec (&expr->ts);
2491   se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
2492   se->expr = convert (type, se->expr);
2493 }
2494
2495
2496 /* Returns the starting position of a substring within a string.  */
2497
2498 static void
2499 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2500 {
2501   tree logical4_type_node = gfc_get_logical_type (4);
2502   tree args;
2503   tree back;
2504   tree type;
2505   tree tmp;
2506
2507   args = gfc_conv_intrinsic_function_args (se, expr);
2508   type = gfc_typenode_for_spec (&expr->ts);
2509   tmp = gfc_advance_chain (args, 3);
2510   if (TREE_CHAIN (tmp) == NULL_TREE)
2511     {
2512       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2513                         NULL_TREE);
2514       TREE_CHAIN (tmp) = back;
2515     }
2516   else
2517     {
2518       back = TREE_CHAIN (tmp);
2519       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2520     }
2521
2522   se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
2523   se->expr = convert (type, se->expr);
2524 }
2525
2526 /* The ascii value for a single character.  */
2527 static void
2528 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2529 {
2530   tree arg;
2531   tree type;
2532
2533   arg = gfc_conv_intrinsic_function_args (se, expr);
2534   arg = TREE_VALUE (TREE_CHAIN (arg));
2535   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2536   arg = build1 (NOP_EXPR, pchar_type_node, arg);
2537   type = gfc_typenode_for_spec (&expr->ts);
2538
2539   se->expr = build_fold_indirect_ref (arg);
2540   se->expr = convert (type, se->expr);
2541 }
2542
2543
2544 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2545
2546 static void
2547 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2548 {
2549   tree arg;
2550   tree tsource;
2551   tree fsource;
2552   tree mask;
2553   tree type;
2554   tree len;
2555
2556   arg = gfc_conv_intrinsic_function_args (se, expr);
2557   if (expr->ts.type != BT_CHARACTER)
2558     {
2559       tsource = TREE_VALUE (arg);
2560       arg = TREE_CHAIN (arg);
2561       fsource = TREE_VALUE (arg);
2562       mask = TREE_VALUE (TREE_CHAIN (arg));
2563     }
2564   else
2565     {
2566       /* We do the same as in the non-character case, but the argument
2567          list is different because of the string length arguments. We
2568          also have to set the string length for the result.  */
2569       len = TREE_VALUE (arg);
2570       arg = TREE_CHAIN (arg);
2571       tsource = TREE_VALUE (arg);
2572       arg = TREE_CHAIN (TREE_CHAIN (arg));
2573       fsource = TREE_VALUE (arg);
2574       mask = TREE_VALUE (TREE_CHAIN (arg));
2575
2576       se->string_length = len;
2577     }
2578   type = TREE_TYPE (tsource);
2579   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2580 }
2581
2582
2583 static void
2584 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2585 {
2586   gfc_actual_arglist *actual;
2587   tree args;
2588   tree type;
2589   tree fndecl;
2590   gfc_se argse;
2591   gfc_ss *ss;
2592
2593   gfc_init_se (&argse, NULL);
2594   actual = expr->value.function.actual;
2595
2596   ss = gfc_walk_expr (actual->expr);
2597   gcc_assert (ss != gfc_ss_terminator);
2598   argse.want_pointer = 1;
2599   argse.data_not_needed = 1;
2600   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2601   gfc_add_block_to_block (&se->pre, &argse.pre);
2602   gfc_add_block_to_block (&se->post, &argse.post);
2603   args = gfc_chainon_list (NULL_TREE, argse.expr);
2604
2605   actual = actual->next;
2606   if (actual->expr)
2607     {
2608       gfc_init_se (&argse, NULL);
2609       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2610       gfc_add_block_to_block (&se->pre, &argse.pre);
2611       args = gfc_chainon_list (args, argse.expr);
2612       fndecl = gfor_fndecl_size1;
2613     }
2614   else
2615     fndecl = gfor_fndecl_size0;
2616
2617   se->expr = build_function_call_expr (fndecl, args);
2618   type = gfc_typenode_for_spec (&expr->ts);
2619   se->expr = convert (type, se->expr);
2620 }
2621
2622
2623 /* Intrinsic string comparison functions.  */
2624
2625   static void
2626 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2627 {
2628   tree type;
2629   tree args;
2630   tree arg2;
2631
2632   args = gfc_conv_intrinsic_function_args (se, expr);
2633   arg2 = TREE_CHAIN (TREE_CHAIN (args));
2634
2635   se->expr = gfc_build_compare_string (TREE_VALUE (args),
2636                 TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
2637                 TREE_VALUE (TREE_CHAIN (arg2)));
2638
2639   type = gfc_typenode_for_spec (&expr->ts);
2640   se->expr = fold_build2 (op, type, se->expr,
2641                      build_int_cst (TREE_TYPE (se->expr), 0));
2642 }
2643
2644 /* Generate a call to the adjustl/adjustr library function.  */
2645 static void
2646 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2647 {
2648   tree args;
2649   tree len;
2650   tree type;
2651   tree var;
2652   tree tmp;
2653
2654   args = gfc_conv_intrinsic_function_args (se, expr);
2655   len = TREE_VALUE (args);
2656
2657   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2658   var = gfc_conv_string_tmp (se, type, len);
2659   args = tree_cons (NULL_TREE, var, args);
2660
2661   tmp = build_function_call_expr (fndecl, args);
2662   gfc_add_expr_to_block (&se->pre, tmp);
2663   se->expr = var;
2664   se->string_length = len;
2665 }
2666
2667
2668 /* A helper function for gfc_conv_intrinsic_array_transfer to compute
2669    the size of tree expressions in bytes.  */
2670 static tree
2671 gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
2672 {
2673   tree tmp;
2674
2675   if (e->ts.type == BT_CHARACTER)
2676     tmp = se->string_length;
2677   else
2678     {
2679       if (e->rank)
2680         {
2681           tmp = gfc_get_element_type (TREE_TYPE (se->expr));
2682           tmp = size_in_bytes (tmp);
2683         }
2684       else
2685         tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
2686     }
2687
2688   return fold_convert (gfc_array_index_type, tmp);
2689 }
2690
2691
2692 /* Array transfer statement.
2693      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2694    where:
2695      typeof<DEST> = typeof<MOLD>
2696    and:
2697      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2698               sizeof (DEST(0) * SIZE).  */
2699
2700 static void
2701 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
2702 {
2703   tree tmp;
2704   tree extent;
2705   tree source;
2706   tree source_bytes;
2707   tree dest_word_len;
2708   tree size_words;
2709   tree size_bytes;
2710   tree upper;
2711   tree lower;
2712   tree stride;
2713   tree stmt;
2714   tree args;
2715   gfc_actual_arglist *arg;
2716   gfc_se argse;
2717   gfc_ss *ss;
2718   gfc_ss_info *info;
2719   stmtblock_t block;
2720   int n;
2721
2722   gcc_assert (se->loop);
2723   info = &se->ss->data.info;
2724
2725   /* Convert SOURCE.  The output from this stage is:-
2726         source_bytes = length of the source in bytes
2727         source = pointer to the source data.  */
2728   arg = expr->value.function.actual;
2729   gfc_init_se (&argse, NULL);
2730   ss = gfc_walk_expr (arg->expr);
2731
2732   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
2733
2734   /* Obtain the pointer to source and the length of source in bytes.  */
2735   if (ss == gfc_ss_terminator)
2736     {
2737       gfc_conv_expr_reference (&argse, arg->expr);
2738       source = argse.expr;
2739
2740       /* Obtain the source word length.  */
2741       tmp = gfc_size_in_bytes (&argse, arg->expr);
2742     }
2743   else
2744     {
2745       gfc_init_se (&argse, NULL);
2746       argse.want_pointer = 0;
2747       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2748       source = gfc_conv_descriptor_data_get (argse.expr);
2749
2750       /* Repack the source if not a full variable array.  */
2751       if (!(arg->expr->expr_type == EXPR_VARIABLE
2752               && arg->expr->ref->u.ar.type == AR_FULL))
2753         {
2754           tmp = build_fold_addr_expr (argse.expr);
2755           tmp = gfc_chainon_list (NULL_TREE, tmp);
2756           source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
2757           source = gfc_evaluate_now (source, &argse.pre);
2758
2759           /* Free the temporary.  */
2760           gfc_start_block (&block);
2761           tmp = convert (pvoid_type_node, source);
2762           tmp = gfc_chainon_list (NULL_TREE, tmp);
2763           tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2764           gfc_add_expr_to_block (&block, tmp);
2765           stmt = gfc_finish_block (&block);
2766
2767           /* Clean up if it was repacked.  */
2768           gfc_init_block (&block);
2769           tmp = gfc_conv_array_data (argse.expr);
2770           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
2771           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
2772           gfc_add_expr_to_block (&block, tmp);
2773           gfc_add_block_to_block (&block, &se->post);
2774           gfc_init_block (&se->post);
2775           gfc_add_block_to_block (&se->post, &block);
2776         }
2777
2778       /* Obtain the source word length.  */
2779       tmp = gfc_size_in_bytes (&argse, arg->expr);
2780
2781       /* Obtain the size of the array in bytes.  */
2782       extent = gfc_create_var (gfc_array_index_type, NULL);
2783       for (n = 0; n < arg->expr->rank; n++)
2784         {
2785           tree idx;
2786           idx = gfc_rank_cst[n];
2787           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2788           stride = gfc_conv_descriptor_stride (argse.expr, idx);
2789           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2790           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2791           tmp = build2 (MINUS_EXPR, gfc_array_index_type,
2792                         upper, lower);
2793           gfc_add_modify_expr (&argse.pre, extent, tmp);
2794           tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2795                         extent, gfc_index_one_node);
2796           tmp = build2 (MULT_EXPR, gfc_array_index_type,
2797                         tmp, source_bytes);
2798         }
2799     }
2800
2801   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2802   gfc_add_block_to_block (&se->pre, &argse.pre);
2803   gfc_add_block_to_block (&se->post, &argse.post);
2804
2805   /* Now convert MOLD.  The sole output is:
2806         dest_word_len = destination word length in bytes.  */
2807   arg = arg->next;
2808
2809   gfc_init_se (&argse, NULL);
2810   ss = gfc_walk_expr (arg->expr);
2811
2812   if (ss == gfc_ss_terminator)
2813     {
2814       gfc_conv_expr_reference (&argse, arg->expr);
2815
2816       /* Obtain the source word length.  */
2817       tmp = gfc_size_in_bytes (&argse, arg->expr);
2818     }
2819   else
2820     {
2821       gfc_init_se (&argse, NULL);
2822       argse.want_pointer = 0;
2823       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2824
2825       /* Obtain the source word length.  */
2826       tmp = gfc_size_in_bytes (&argse, arg->expr);
2827     }
2828
2829   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
2830   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
2831
2832   /* Finally convert SIZE, if it is present.  */
2833   arg = arg->next;
2834   size_words = gfc_create_var (gfc_array_index_type, NULL);
2835
2836   if (arg->expr)
2837     {
2838       gfc_init_se (&argse, NULL);
2839       gfc_conv_expr_reference (&argse, arg->expr);
2840       tmp = convert (gfc_array_index_type,
2841                          build_fold_indirect_ref (argse.expr));
2842       gfc_add_block_to_block (&se->pre, &argse.pre);
2843       gfc_add_block_to_block (&se->post, &argse.post);
2844     }
2845   else
2846     tmp = NULL_TREE;
2847
2848   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
2849   if (tmp != NULL_TREE)
2850     {
2851       tmp = build2 (MULT_EXPR, gfc_array_index_type,
2852                     tmp, dest_word_len);
2853       tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
2854     }
2855   else
2856     tmp = source_bytes;
2857
2858   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
2859   gfc_add_modify_expr (&se->pre, size_words,
2860                        build2 (CEIL_DIV_EXPR, gfc_array_index_type,
2861                                size_bytes, dest_word_len));
2862
2863   /* Evaluate the bounds of the result.  If the loop range exists, we have
2864      to check if it is too large.  If so, we modify loop->to be consistent
2865      with min(size, size(source)).  Otherwise, size is made consistent with
2866      the loop range, so that the right number of bytes is transferred.*/
2867   n = se->loop->order[0];
2868   if (se->loop->to[n] != NULL_TREE)
2869     {
2870       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2871                          se->loop->to[n], se->loop->from[n]);
2872       tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2873                     tmp, gfc_index_one_node);
2874       tmp = build2 (MIN_EXPR, gfc_array_index_type,
2875                     tmp, size_words);
2876       gfc_add_modify_expr (&se->pre, size_words, tmp);
2877       gfc_add_modify_expr (&se->pre, size_bytes,
2878                            build2 (MULT_EXPR, gfc_array_index_type,
2879                            size_words, dest_word_len));
2880       upper = build2 (PLUS_EXPR, gfc_array_index_type,
2881                       size_words, se->loop->from[n]);
2882       upper = build2 (MINUS_EXPR, gfc_array_index_type,
2883                       upper, gfc_index_one_node);
2884     }
2885   else
2886     {
2887       upper = build2 (MINUS_EXPR, gfc_array_index_type,
2888                       size_words, gfc_index_one_node);
2889       se->loop->from[n] = gfc_index_zero_node;
2890     }
2891
2892   se->loop->to[n] = upper;
2893
2894   /* Build a destination descriptor, using the pointer, source, as the
2895      data field.  This is already allocated so set callee_alloc.  */
2896   tmp = gfc_typenode_for_spec (&expr->ts);
2897   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
2898                                info, tmp, false, true, false, false);
2899
2900   /* Use memcpy to do the transfer.  */
2901   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2902   args = gfc_chainon_list (NULL_TREE, tmp);
2903   tmp = fold_convert (pvoid_type_node, source);
2904   args = gfc_chainon_list (args, source);
2905   args = gfc_chainon_list (args, size_bytes);
2906   tmp = built_in_decls[BUILT_IN_MEMCPY];
2907   tmp = build_function_call_expr (tmp, args);
2908   gfc_add_expr_to_block (&se->pre, tmp);
2909
2910   se->expr = info->descriptor;
2911   if (expr->ts.type == BT_CHARACTER)
2912     se->string_length = dest_word_len;
2913 }
2914
2915
2916 /* Scalar transfer statement.
2917    TRANSFER (source, mold) = *(typeof<mold> *)&source.  */
2918
2919 static void
2920 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2921 {
2922   gfc_actual_arglist *arg;
2923   gfc_se argse;
2924   tree type;
2925   tree ptr;
2926   gfc_ss *ss;
2927
2928   /* Get a pointer to the source.  */
2929   arg = expr->value.function.actual;
2930   ss = gfc_walk_expr (arg->expr);
2931   gfc_init_se (&argse, NULL);
2932   if (ss == gfc_ss_terminator)
2933     gfc_conv_expr_reference (&argse, arg->expr);
2934   else
2935     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2936   gfc_add_block_to_block (&se->pre, &argse.pre);
2937   gfc_add_block_to_block (&se->post, &argse.post);
2938   ptr = argse.expr;
2939
2940   arg = arg->next;
2941   type = gfc_typenode_for_spec (&expr->ts);
2942   ptr = convert (build_pointer_type (type), ptr);
2943   if (expr->ts.type == BT_CHARACTER)
2944     {
2945       gfc_init_se (&argse, NULL);
2946       gfc_conv_expr (&argse, arg->expr);
2947       gfc_add_block_to_block (&se->pre, &argse.pre);
2948       gfc_add_block_to_block (&se->post, &argse.post);
2949       se->expr = ptr;
2950       se->string_length = argse.string_length;
2951     }
2952   else
2953     {
2954       se->expr = build_fold_indirect_ref (ptr);
2955     }
2956 }
2957
2958
2959 /* Generate code for the ALLOCATED intrinsic.
2960    Generate inline code that directly check the address of the argument.  */
2961
2962 static void
2963 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2964 {
2965   gfc_actual_arglist *arg1;
2966   gfc_se arg1se;
2967   gfc_ss *ss1;
2968   tree tmp;
2969
2970   gfc_init_se (&arg1se, NULL);
2971   arg1 = expr->value.function.actual;
2972   ss1 = gfc_walk_expr (arg1->expr);
2973   arg1se.descriptor_only = 1;
2974   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2975
2976   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
2977   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2978                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2979   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2980 }
2981
2982
2983 /* Generate code for the ASSOCIATED intrinsic.
2984    If both POINTER and TARGET are arrays, generate a call to library function
2985    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2986    In other cases, generate inline code that directly compare the address of
2987    POINTER with the address of TARGET.  */
2988
2989 static void
2990 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2991 {
2992   gfc_actual_arglist *arg1;
2993   gfc_actual_arglist *arg2;
2994   gfc_se arg1se;
2995   gfc_se arg2se;
2996   tree tmp2;
2997   tree tmp;
2998   tree args, fndecl;
2999   tree nonzero_charlen;
3000   tree nonzero_arraylen;
3001   gfc_ss *ss1, *ss2;
3002
3003   gfc_init_se (&arg1se, NULL);
3004   gfc_init_se (&arg2se, NULL);
3005   arg1 = expr->value.function.actual;
3006   arg2 = arg1->next;
3007   ss1 = gfc_walk_expr (arg1->expr);
3008
3009   if (!arg2->expr)
3010     {
3011       /* No optional target.  */
3012       if (ss1 == gfc_ss_terminator)
3013         {
3014           /* A pointer to a scalar.  */
3015           arg1se.want_pointer = 1;
3016           gfc_conv_expr (&arg1se, arg1->expr);
3017           tmp2 = arg1se.expr;
3018         }
3019       else
3020         {
3021           /* A pointer to an array.  */
3022           arg1se.descriptor_only = 1;
3023           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3024           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3025         }
3026       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3027       gfc_add_block_to_block (&se->post, &arg1se.post);
3028       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3029                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3030       se->expr = tmp;
3031     }
3032   else
3033     {
3034       /* An optional target.  */
3035       ss2 = gfc_walk_expr (arg2->expr);
3036
3037       nonzero_charlen = NULL_TREE;
3038       if (arg1->expr->ts.type == BT_CHARACTER)
3039         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3040                                   arg1->expr->ts.cl->backend_decl,
3041                                   integer_zero_node);
3042
3043       if (ss1 == gfc_ss_terminator)
3044         {
3045           /* A pointer to a scalar.  */
3046           gcc_assert (ss2 == gfc_ss_terminator);
3047           arg1se.want_pointer = 1;
3048           gfc_conv_expr (&arg1se, arg1->expr);
3049           arg2se.want_pointer = 1;
3050           gfc_conv_expr (&arg2se, arg2->expr);
3051           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3052           gfc_add_block_to_block (&se->post, &arg1se.post);
3053           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3054           se->expr = tmp;
3055         }
3056       else
3057         {
3058
3059           /* An array pointer of zero length is not associated if target is
3060              present.  */
3061           arg1se.descriptor_only = 1;
3062           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3063           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3064                                             gfc_rank_cst[arg1->expr->rank - 1]);
3065           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3066                                  tmp, integer_zero_node);
3067
3068           /* A pointer to an array, call library function _gfor_associated.  */
3069           gcc_assert (ss2 != gfc_ss_terminator);
3070           args = NULL_TREE;
3071           arg1se.want_pointer = 1;
3072           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3073           args = gfc_chainon_list (args, arg1se.expr);
3074
3075           arg2se.want_pointer = 1;
3076           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3077           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3078           gfc_add_block_to_block (&se->post, &arg2se.post);
3079           args = gfc_chainon_list (args, arg2se.expr);
3080           fndecl = gfor_fndecl_associated;
3081           se->expr = build_function_call_expr (fndecl, args);
3082           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3083                              se->expr, nonzero_arraylen);
3084
3085         }
3086
3087       /* If target is present zero character length pointers cannot
3088          be associated.  */
3089       if (nonzero_charlen != NULL_TREE)
3090         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3091                            se->expr, nonzero_charlen);
3092     }
3093
3094   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3095 }
3096
3097
3098 /* Scan a string for any one of the characters in a set of characters.  */
3099
3100 static void
3101 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
3102 {
3103   tree logical4_type_node = gfc_get_logical_type (4);
3104   tree args;
3105   tree back;
3106   tree type;
3107   tree tmp;
3108
3109   args = gfc_conv_intrinsic_function_args (se, expr);
3110   type = gfc_typenode_for_spec (&expr->ts);
3111   tmp = gfc_advance_chain (args, 3);
3112   if (TREE_CHAIN (tmp) == NULL_TREE)
3113     {
3114       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
3115                         NULL_TREE);
3116       TREE_CHAIN (tmp) = back;
3117     }
3118   else
3119     {
3120       back = TREE_CHAIN (tmp);
3121       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
3122     }
3123
3124   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
3125   se->expr = convert (type, se->expr);
3126 }
3127
3128
3129 /* Verify that a set of characters contains all the characters in a string
3130    by identifying the position of the first character in a string of
3131    characters that does not appear in a given set of characters.  */
3132
3133 static void
3134 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
3135 {
3136   tree logical4_type_node = gfc_get_logical_type (4);
3137   tree args;
3138   tree back;
3139   tree type;
3140   tree tmp;
3141
3142   args = gfc_conv_intrinsic_function_args (se, expr);
3143   type = gfc_typenode_for_spec (&expr->ts);
3144   tmp = gfc_advance_chain (args, 3);
3145   if (TREE_CHAIN (tmp) == NULL_TREE)
3146     {
3147       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
3148                         NULL_TREE);
3149       TREE_CHAIN (tmp) = back;
3150     }
3151   else
3152     {
3153       back = TREE_CHAIN (tmp);
3154       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
3155     }
3156
3157   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
3158   se->expr = convert (type, se->expr);
3159 }
3160
3161
3162 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3163
3164 static void
3165 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3166 {
3167   tree args;
3168
3169   args = gfc_conv_intrinsic_function_args (se, expr);
3170   args = TREE_VALUE (args);
3171   args = build_fold_addr_expr (args);
3172   args = tree_cons (NULL_TREE, args, NULL_TREE);
3173   se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
3174 }
3175
3176 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3177
3178 static void
3179 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3180 {
3181   gfc_actual_arglist *actual;
3182   tree args;
3183   gfc_se argse;
3184
3185   args = NULL_TREE;
3186   for (actual = expr->value.function.actual; actual; actual = actual->next)
3187     {
3188       gfc_init_se (&argse, se);
3189
3190       /* Pass a NULL pointer for an absent arg.  */
3191       if (actual->expr == NULL)
3192         argse.expr = null_pointer_node;
3193       else
3194         gfc_conv_expr_reference (&argse, actual->expr);
3195
3196       gfc_add_block_to_block (&se->pre, &argse.pre);
3197       gfc_add_block_to_block (&se->post, &argse.post);
3198       args = gfc_chainon_list (args, argse.expr);
3199     }
3200   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3201 }
3202
3203
3204 /* Generate code for TRIM (A) intrinsic function.  */
3205
3206 static void
3207 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3208 {
3209   tree gfc_int4_type_node = gfc_get_int_type (4);
3210   tree var;
3211   tree len;
3212   tree addr;
3213   tree tmp;
3214   tree arglist;
3215   tree type;
3216   tree cond;
3217
3218   arglist = NULL_TREE;
3219
3220   type = build_pointer_type (gfc_character1_type_node);
3221   var = gfc_create_var (type, "pstr");
3222   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3223   len = gfc_create_var (gfc_int4_type_node, "len");
3224
3225   tmp = gfc_conv_intrinsic_function_args (se, expr);
3226   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
3227   arglist = gfc_chainon_list (arglist, addr);
3228   arglist = chainon (arglist, tmp);
3229
3230   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
3231   gfc_add_expr_to_block (&se->pre, tmp);
3232
3233   /* Free the temporary afterwards, if necessary.  */
3234   cond = build2 (GT_EXPR, boolean_type_node, len,
3235                  build_int_cst (TREE_TYPE (len), 0));
3236   arglist = gfc_chainon_list (NULL_TREE, var);
3237   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
3238   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3239   gfc_add_expr_to_block (&se->post, tmp);
3240
3241   se->expr = var;
3242   se->string_length = len;
3243 }
3244
3245
3246 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3247
3248 static void
3249 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3250 {
3251   tree gfc_int4_type_node = gfc_get_int_type (4);
3252   tree tmp;
3253   tree len;
3254   tree args;
3255   tree arglist;
3256   tree ncopies;
3257   tree var;
3258   tree type;
3259
3260   args = gfc_conv_intrinsic_function_args (se, expr);
3261   len = TREE_VALUE (args);
3262   tmp = gfc_advance_chain (args, 2);
3263   ncopies = TREE_VALUE (tmp);
3264   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
3265   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3266   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
3267
3268   arglist = NULL_TREE;
3269   arglist = gfc_chainon_list (arglist, var);
3270   arglist = chainon (arglist, args);
3271   tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
3272   gfc_add_expr_to_block (&se->pre, tmp);
3273
3274   se->expr = var;
3275   se->string_length = len;
3276 }
3277
3278
3279 /* Generate code for the IARGC intrinsic.  */
3280
3281 static void
3282 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3283 {
3284   tree tmp;
3285   tree fndecl;
3286   tree type;
3287
3288   /* Call the library function.  This always returns an INTEGER(4).  */
3289   fndecl = gfor_fndecl_iargc;
3290   tmp = build_function_call_expr (fndecl, NULL_TREE);
3291
3292   /* Convert it to the required type.  */
3293   type = gfc_typenode_for_spec (&expr->ts);
3294   tmp = fold_convert (type, tmp);
3295
3296   se->expr = tmp;
3297 }
3298
3299
3300 /* The loc intrinsic returns the address of its argument as
3301    gfc_index_integer_kind integer.  */
3302
3303 static void
3304 gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
3305 {
3306   tree temp_var;
3307   gfc_expr *arg_expr;
3308   gfc_ss *ss;
3309
3310   gcc_assert (!se->ss);
3311
3312   arg_expr = expr->value.function.actual->expr;
3313   ss = gfc_walk_expr (arg_expr);
3314   if (ss == gfc_ss_terminator)
3315     gfc_conv_expr_reference (se, arg_expr);
3316   else
3317     gfc_conv_array_parameter (se, arg_expr, ss, 1); 
3318   se->expr= convert (gfc_unsigned_type (long_integer_type_node), 
3319                      se->expr);
3320    
3321   /* Create a temporary variable for loc return value.  Without this, 
3322      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3323   temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node), 
3324                              NULL);
3325   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3326   se->expr = temp_var;
3327 }
3328
3329 /* Generate code for an intrinsic function.  Some map directly to library
3330    calls, others get special handling.  In some cases the name of the function
3331    used depends on the type specifiers.  */
3332
3333 void
3334 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3335 {
3336   gfc_intrinsic_sym *isym;
3337   const char *name;
3338   int lib;
3339
3340   isym = expr->value.function.isym;
3341
3342   name = &expr->value.function.name[2];
3343
3344   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3345     {
3346       lib = gfc_is_intrinsic_libcall (expr);
3347       if (lib != 0)
3348         {
3349           if (lib == 1)
3350             se->ignore_optional = 1;
3351           gfc_conv_intrinsic_funcall (se, expr);
3352           return;
3353         }
3354     }
3355
3356   switch (expr->value.function.isym->generic_id)
3357     {
3358     case GFC_ISYM_NONE:
3359       gcc_unreachable ();
3360
3361     case GFC_ISYM_REPEAT:
3362       gfc_conv_intrinsic_repeat (se, expr);
3363       break;
3364
3365     case GFC_ISYM_TRIM:
3366       gfc_conv_intrinsic_trim (se, expr);
3367       break;
3368
3369     case GFC_ISYM_SI_KIND:
3370       gfc_conv_intrinsic_si_kind (se, expr);
3371       break;
3372
3373     case GFC_ISYM_SR_KIND:
3374       gfc_conv_intrinsic_sr_kind (se, expr);
3375       break;
3376
3377     case GFC_ISYM_EXPONENT:
3378       gfc_conv_intrinsic_exponent (se, expr);
3379       break;
3380
3381     case GFC_ISYM_SCAN:
3382       gfc_conv_intrinsic_scan (se, expr);
3383       break;
3384
3385     case GFC_ISYM_VERIFY:
3386       gfc_conv_intrinsic_verify (se, expr);
3387       break;
3388
3389     case GFC_ISYM_ALLOCATED:
3390       gfc_conv_allocated (se, expr);
3391       break;
3392
3393     case GFC_ISYM_ASSOCIATED:
3394       gfc_conv_associated(se, expr);
3395       break;
3396
3397     case GFC_ISYM_ABS:
3398       gfc_conv_intrinsic_abs (se, expr);
3399       break;
3400
3401     case GFC_ISYM_ADJUSTL:
3402       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3403       break;
3404
3405     case GFC_ISYM_ADJUSTR:
3406       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3407       break;
3408
3409     case GFC_ISYM_AIMAG:
3410       gfc_conv_intrinsic_imagpart (se, expr);
3411       break;
3412
3413     case GFC_ISYM_AINT:
3414       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
3415       break;
3416
3417     case GFC_ISYM_ALL:
3418       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3419       break;
3420
3421     case GFC_ISYM_ANINT:
3422       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
3423       break;
3424
3425     case GFC_ISYM_AND:
3426       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3427       break;
3428
3429     case GFC_ISYM_ANY:
3430       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3431       break;
3432
3433     case GFC_ISYM_BTEST:
3434       gfc_conv_intrinsic_btest (se, expr);
3435       break;
3436
3437     case GFC_ISYM_ACHAR:
3438     case GFC_ISYM_CHAR:
3439       gfc_conv_intrinsic_char (se, expr);
3440       break;
3441
3442     case GFC_ISYM_CONVERSION:
3443     case GFC_ISYM_REAL:
3444     case GFC_ISYM_LOGICAL:
3445     case GFC_ISYM_DBLE:
3446       gfc_conv_intrinsic_conversion (se, expr);
3447       break;
3448
3449       /* Integer conversions are handled separately to make sure we get the
3450          correct rounding mode.  */
3451     case GFC_ISYM_INT:
3452     case GFC_ISYM_INT2:
3453     case GFC_ISYM_INT8:
3454     case GFC_ISYM_LONG:
3455       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
3456       break;
3457
3458     case GFC_ISYM_NINT:
3459       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
3460       break;
3461
3462     case GFC_ISYM_CEILING:
3463       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
3464       break;
3465
3466     case GFC_ISYM_FLOOR:
3467       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
3468       break;
3469
3470     case GFC_ISYM_MOD:
3471       gfc_conv_intrinsic_mod (se, expr, 0);
3472       break;
3473
3474     case GFC_ISYM_MODULO:
3475       gfc_conv_intrinsic_mod (se, expr, 1);
3476       break;
3477
3478     case GFC_ISYM_CMPLX:
3479       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3480       break;
3481
3482     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3483       gfc_conv_intrinsic_iargc (se, expr);
3484       break;
3485
3486     case GFC_ISYM_COMPLEX:
3487       gfc_conv_intrinsic_cmplx (se, expr, 1);
3488       break;
3489
3490     case GFC_ISYM_CONJG:
3491       gfc_conv_intrinsic_conjg (se, expr);
3492       break;
3493
3494     case GFC_ISYM_COUNT:
3495       gfc_conv_intrinsic_count (se, expr);
3496       break;
3497
3498     case GFC_ISYM_CTIME:
3499       gfc_conv_intrinsic_ctime (se, expr);
3500       break;
3501
3502     case GFC_ISYM_DIM:
3503       gfc_conv_intrinsic_dim (se, expr);
3504       break;
3505
3506     case GFC_ISYM_DOT_PRODUCT:
3507       gfc_conv_intrinsic_dot_product (se, expr);
3508       break;
3509
3510     case GFC_ISYM_DPROD:
3511       gfc_conv_intrinsic_dprod (se, expr);
3512       break;
3513
3514     case GFC_ISYM_FDATE:
3515       gfc_conv_intrinsic_fdate (se, expr);
3516       break;
3517
3518     case GFC_ISYM_IAND:
3519       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3520       break;
3521
3522     case GFC_ISYM_IBCLR:
3523       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3524       break;
3525
3526     case GFC_ISYM_IBITS:
3527       gfc_conv_intrinsic_ibits (se, expr);
3528       break;
3529
3530     case GFC_ISYM_IBSET:
3531       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3532       break;
3533
3534     case GFC_ISYM_IACHAR:
3535     case GFC_ISYM_ICHAR:
3536       /* We assume ASCII character sequence.  */
3537       gfc_conv_intrinsic_ichar (se, expr);
3538       break;
3539
3540     case GFC_ISYM_IARGC:
3541       gfc_conv_intrinsic_iargc (se, expr);
3542       break;
3543
3544     case GFC_ISYM_IEOR:
3545       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3546       break;
3547
3548     case GFC_ISYM_INDEX:
3549       gfc_conv_intrinsic_index (se, expr);
3550       break;
3551
3552     case GFC_ISYM_IOR:
3553       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3554       break;
3555
3556     case GFC_ISYM_LSHIFT:
3557       gfc_conv_intrinsic_rlshift (se, expr, 0);
3558       break;
3559
3560     case GFC_ISYM_RSHIFT:
3561       gfc_conv_intrinsic_rlshift (se, expr, 1);
3562       break;