OSDN Git Service

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