OSDN Git Service

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