OSDN Git Service

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