1 /* Intrinsic translation
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
23
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
28 #include "tree.h"
29 #include "gfortran.h"
30 #include "trans.h"
31 #include "stringpool.h"
32 #include "fold-const.h"
33 #include "tree-nested.h"
34 #include "stor-layout.h"
35 #include "toplev.h" /* For rest_of_decl_compilation. */
36 #include "arith.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 #include "dependency.h" /* For CAF array alias analysis. */
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42
43 /* This maps Fortran intrinsic math functions to external library or GCC
44 builtin functions. */
45 typedef struct GTY(()) gfc_intrinsic_map_t {
46 /* The explicit enum is required to work around inadequacies in the
47 garbage collection/gengtype parsing mechanism. */
48 enum gfc_isym_id id;
49
50 /* Enum value from the "language-independent", aka C-centric, part
51 of gcc, or END_BUILTINS of no such value set. */
52 enum built_in_function float_built_in;
53 enum built_in_function double_built_in;
54 enum built_in_function long_double_built_in;
55 enum built_in_function complex_float_built_in;
56 enum built_in_function complex_double_built_in;
57 enum built_in_function complex_long_double_built_in;
58
59 /* True if the naming pattern is to prepend "c" for complex and
60 append "f" for kind=4. False if the naming pattern is to
61 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
62 bool libm_name;
63
64 /* True if a complex version of the function exists. */
65 bool complex_available;
66
67 /* True if the function should be marked const. */
68 bool is_constant;
69
70 /* The base library name of this function. */
71 const char *name;
72
73 /* Cache decls created for the various operand types. */
74 tree real4_decl;
75 tree real8_decl;
76 tree real10_decl;
77 tree real16_decl;
78 tree complex4_decl;
79 tree complex8_decl;
80 tree complex10_decl;
81 tree complex16_decl;
82 }
83 gfc_intrinsic_map_t;
84
85 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
86 defines complex variants of all of the entries in mathbuiltins.def
87 except for atan2. */
88 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
89 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
90 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
91 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
92 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
93
94 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
97 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99
100 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
102 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
105
106 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
107 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
108 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
111
112 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
113 {
114 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
115 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
116 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
117 #include "mathbuiltins.def"
118
119 /* Functions in libgfortran. */
120 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
121
122 /* End the list. */
123 LIB_FUNCTION (NONE, NULL, false)
124
125 };
126 #undef OTHER_BUILTIN
127 #undef LIB_FUNCTION
128 #undef DEFINE_MATH_BUILTIN
129 #undef DEFINE_MATH_BUILTIN_C
130
131
132 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
133
134
135 /* Find the correct variant of a given builtin from its argument. */
136 static tree
builtin_decl_for_precision(enum built_in_function base_built_in,int precision)137 builtin_decl_for_precision (enum built_in_function base_built_in,
138 int precision)
139 {
140 enum built_in_function i = END_BUILTINS;
141
142 gfc_intrinsic_map_t *m;
143 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
144 ;
145
146 if (precision == TYPE_PRECISION (float_type_node))
147 i = m->float_built_in;
148 else if (precision == TYPE_PRECISION (double_type_node))
149 i = m->double_built_in;
150 else if (precision == TYPE_PRECISION (long_double_type_node))
151 i = m->long_double_built_in;
152 else if (precision == TYPE_PRECISION (float128_type_node))
153 {
154 /* Special treatment, because it is not exactly a built-in, but
155 a library function. */
156 return m->real16_decl;
157 }
158
159 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
160 }
161
162
163 tree
gfc_builtin_decl_for_float_kind(enum built_in_function double_built_in,int kind)164 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
165 int kind)
166 {
167 int i = gfc_validate_kind (BT_REAL, kind, false);
168
169 if (gfc_real_kinds[i].c_float128)
170 {
171 /* For __float128, the story is a bit different, because we return
172 a decl to a library function rather than a built-in. */
173 gfc_intrinsic_map_t *m;
174 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
175 ;
176
177 return m->real16_decl;
178 }
179
180 return builtin_decl_for_precision (double_built_in,
181 gfc_real_kinds[i].mode_precision);
182 }
183
184
185 /* Evaluate the arguments to an intrinsic function. The value
186 of NARGS may be less than the actual number of arguments in EXPR
187 to allow optional "KIND" arguments that are not included in the
188 generated code to be ignored. */
189
190 static void
gfc_conv_intrinsic_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)191 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
192 tree *argarray, int nargs)
193 {
194 gfc_actual_arglist *actual;
195 gfc_expr *e;
196 gfc_intrinsic_arg *formal;
197 gfc_se argse;
198 int curr_arg;
199
200 formal = expr->value.function.isym->formal;
201 actual = expr->value.function.actual;
202
203 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
204 actual = actual->next,
205 formal = formal ? formal->next : NULL)
206 {
207 gcc_assert (actual);
208 e = actual->expr;
209 /* Skip omitted optional arguments. */
210 if (!e)
211 {
212 --curr_arg;
213 continue;
214 }
215
216 /* Evaluate the parameter. This will substitute scalarized
217 references automatically. */
218 gfc_init_se (&argse, se);
219
220 if (e->ts.type == BT_CHARACTER)
221 {
222 gfc_conv_expr (&argse, e);
223 gfc_conv_string_parameter (&argse);
224 argarray[curr_arg++] = argse.string_length;
225 gcc_assert (curr_arg < nargs);
226 }
227 else
228 gfc_conv_expr_val (&argse, e);
229
230 /* If an optional argument is itself an optional dummy argument,
231 check its presence and substitute a null if absent. */
232 if (e->expr_type == EXPR_VARIABLE
233 && e->symtree->n.sym->attr.optional
234 && formal
235 && formal->optional)
236 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
237
238 gfc_add_block_to_block (&se->pre, &argse.pre);
239 gfc_add_block_to_block (&se->post, &argse.post);
240 argarray[curr_arg] = argse.expr;
241 }
242 }
243
244 /* Count the number of actual arguments to the intrinsic function EXPR
245 including any "hidden" string length arguments. */
246
247 static unsigned int
gfc_intrinsic_argument_list_length(gfc_expr * expr)248 gfc_intrinsic_argument_list_length (gfc_expr *expr)
249 {
250 int n = 0;
251 gfc_actual_arglist *actual;
252
253 for (actual = expr->value.function.actual; actual; actual = actual->next)
254 {
255 if (!actual->expr)
256 continue;
257
258 if (actual->expr->ts.type == BT_CHARACTER)
259 n += 2;
260 else
261 n++;
262 }
263
264 return n;
265 }
266
267
268 /* Conversions between different types are output by the frontend as
269 intrinsic functions. We implement these directly with inline code. */
270
271 static void
gfc_conv_intrinsic_conversion(gfc_se * se,gfc_expr * expr)272 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
273 {
274 tree type;
275 tree *args;
276 int nargs;
277
278 nargs = gfc_intrinsic_argument_list_length (expr);
279 args = XALLOCAVEC (tree, nargs);
280
281 /* Evaluate all the arguments passed. Whilst we're only interested in the
282 first one here, there are other parts of the front-end that assume this
283 and will trigger an ICE if it's not the case. */
284 type = gfc_typenode_for_spec (&expr->ts);
285 gcc_assert (expr->value.function.actual->expr);
286 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
287
288 /* Conversion between character kinds involves a call to a library
289 function. */
290 if (expr->ts.type == BT_CHARACTER)
291 {
292 tree fndecl, var, addr, tmp;
293
294 if (expr->ts.kind == 1
295 && expr->value.function.actual->expr->ts.kind == 4)
296 fndecl = gfor_fndecl_convert_char4_to_char1;
297 else if (expr->ts.kind == 4
298 && expr->value.function.actual->expr->ts.kind == 1)
299 fndecl = gfor_fndecl_convert_char1_to_char4;
300 else
301 gcc_unreachable ();
302
303 /* Create the variable storing the converted value. */
304 type = gfc_get_pchar_type (expr->ts.kind);
305 var = gfc_create_var (type, "str");
306 addr = gfc_build_addr_expr (build_pointer_type (type), var);
307
308 /* Call the library function that will perform the conversion. */
309 gcc_assert (nargs >= 2);
310 tmp = build_call_expr_loc (input_location,
311 fndecl, 3, addr, args[0], args[1]);
312 gfc_add_expr_to_block (&se->pre, tmp);
313
314 /* Free the temporary afterwards. */
315 tmp = gfc_call_free (var);
316 gfc_add_expr_to_block (&se->post, tmp);
317
318 se->expr = var;
319 se->string_length = args[0];
320
321 return;
322 }
323
324 /* Conversion from complex to non-complex involves taking the real
325 component of the value. */
326 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
327 && expr->ts.type != BT_COMPLEX)
328 {
329 tree artype;
330
331 artype = TREE_TYPE (TREE_TYPE (args[0]));
332 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
333 args[0]);
334 }
335
336 se->expr = convert (type, args[0]);
337 }
338
339 /* This is needed because the gcc backend only implements
340 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
341 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
342 Similarly for CEILING. */
343
344 static tree
build_fixbound_expr(stmtblock_t * pblock,tree arg,tree type,int up)345 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
346 {
347 tree tmp;
348 tree cond;
349 tree argtype;
350 tree intval;
351
352 argtype = TREE_TYPE (arg);
353 arg = gfc_evaluate_now (arg, pblock);
354
355 intval = convert (type, arg);
356 intval = gfc_evaluate_now (intval, pblock);
357
358 tmp = convert (argtype, intval);
359 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
360 boolean_type_node, tmp, arg);
361
362 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
363 intval, build_int_cst (type, 1));
364 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
365 return tmp;
366 }
367
368
369 /* Round to nearest integer, away from zero. */
370
371 static tree
build_round_expr(tree arg,tree restype)372 build_round_expr (tree arg, tree restype)
373 {
374 tree argtype;
375 tree fn;
376 int argprec, resprec;
377
378 argtype = TREE_TYPE (arg);
379 argprec = TYPE_PRECISION (argtype);
380 resprec = TYPE_PRECISION (restype);
381
382 /* Depending on the type of the result, choose the int intrinsic
383 (iround, available only as a builtin, therefore cannot use it for
384 __float128), long int intrinsic (lround family) or long long
385 intrinsic (llround). We might also need to convert the result
386 afterwards. */
387 if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
388 fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
389 else if (resprec <= LONG_TYPE_SIZE)
390 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
391 else if (resprec <= LONG_LONG_TYPE_SIZE)
392 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
393 else
394 gcc_unreachable ();
395
396 return fold_convert (restype, build_call_expr_loc (input_location,
397 fn, 1, arg));
398 }
399
400
401 /* Convert a real to an integer using a specific rounding mode.
402 Ideally we would just build the corresponding GENERIC node,
403 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
404
405 static tree
build_fix_expr(stmtblock_t * pblock,tree arg,tree type,enum rounding_mode op)406 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
407 enum rounding_mode op)
408 {
409 switch (op)
410 {
411 case RND_FLOOR:
412 return build_fixbound_expr (pblock, arg, type, 0);
413 break;
414
415 case RND_CEIL:
416 return build_fixbound_expr (pblock, arg, type, 1);
417 break;
418
419 case RND_ROUND:
420 return build_round_expr (arg, type);
421 break;
422
423 case RND_TRUNC:
424 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
425 break;
426
427 default:
428 gcc_unreachable ();
429 }
430 }
431
432
433 /* Round a real value using the specified rounding mode.
434 We use a temporary integer of that same kind size as the result.
435 Values larger than those that can be represented by this kind are
436 unchanged, as they will not be accurate enough to represent the
437 rounding.
438 huge = HUGE (KIND (a))
439 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
440 */
441
442 static void
gfc_conv_intrinsic_aint(gfc_se * se,gfc_expr * expr,enum rounding_mode op)443 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
444 {
445 tree type;
446 tree itype;
447 tree arg[2];
448 tree tmp;
449 tree cond;
450 tree decl;
451 mpfr_t huge;
452 int n, nargs;
453 int kind;
454
455 kind = expr->ts.kind;
456 nargs = gfc_intrinsic_argument_list_length (expr);
457
458 decl = NULL_TREE;
459 /* We have builtin functions for some cases. */
460 switch (op)
461 {
462 case RND_ROUND:
463 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
464 break;
465
466 case RND_TRUNC:
467 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
468 break;
469
470 default:
471 gcc_unreachable ();
472 }
473
474 /* Evaluate the argument. */
475 gcc_assert (expr->value.function.actual->expr);
476 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
477
478 /* Use a builtin function if one exists. */
479 if (decl != NULL_TREE)
480 {
481 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
482 return;
483 }
484
485 /* This code is probably redundant, but we'll keep it lying around just
486 in case. */
487 type = gfc_typenode_for_spec (&expr->ts);
488 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
489
490 /* Test if the value is too large to handle sensibly. */
491 gfc_set_model_kind (kind);
492 mpfr_init (huge);
493 n = gfc_validate_kind (BT_INTEGER, kind, false);
494 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
495 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
496 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
497 tmp);
498
499 mpfr_neg (huge, huge, GFC_RND_MODE);
500 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
501 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
502 tmp);
503 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
504 cond, tmp);
505 itype = gfc_get_int_type (kind);
506
507 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
508 tmp = convert (type, tmp);
509 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
510 arg[0]);
511 mpfr_clear (huge);
512 }
513
514
515 /* Convert to an integer using the specified rounding mode. */
516
517 static void
gfc_conv_intrinsic_int(gfc_se * se,gfc_expr * expr,enum rounding_mode op)518 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
519 {
520 tree type;
521 tree *args;
522 int nargs;
523
524 nargs = gfc_intrinsic_argument_list_length (expr);
525 args = XALLOCAVEC (tree, nargs);
526
527 /* Evaluate the argument, we process all arguments even though we only
528 use the first one for code generation purposes. */
529 type = gfc_typenode_for_spec (&expr->ts);
530 gcc_assert (expr->value.function.actual->expr);
531 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
532
533 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
534 {
535 /* Conversion to a different integer kind. */
536 se->expr = convert (type, args[0]);
537 }
538 else
539 {
540 /* Conversion from complex to non-complex involves taking the real
541 component of the value. */
542 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
543 && expr->ts.type != BT_COMPLEX)
544 {
545 tree artype;
546
547 artype = TREE_TYPE (TREE_TYPE (args[0]));
548 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
549 args[0]);
550 }
551
552 se->expr = build_fix_expr (&se->pre, args[0], type, op);
553 }
554 }
555
556
557 /* Get the imaginary component of a value. */
558
559 static void
gfc_conv_intrinsic_imagpart(gfc_se * se,gfc_expr * expr)560 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
561 {
562 tree arg;
563
564 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
565 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
566 TREE_TYPE (TREE_TYPE (arg)), arg);
567 }
568
569
570 /* Get the complex conjugate of a value. */
571
572 static void
gfc_conv_intrinsic_conjg(gfc_se * se,gfc_expr * expr)573 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
574 {
575 tree arg;
576
577 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
578 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
579 }
580
581
582
583 static tree
define_quad_builtin(const char * name,tree type,bool is_const)584 define_quad_builtin (const char *name, tree type, bool is_const)
585 {
586 tree fndecl;
587 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
588 type);
589
590 /* Mark the decl as external. */
591 DECL_EXTERNAL (fndecl) = 1;
592 TREE_PUBLIC (fndecl) = 1;
593
594 /* Mark it __attribute__((const)). */
595 TREE_READONLY (fndecl) = is_const;
596
597 rest_of_decl_compilation (fndecl, 1, 0);
598
599 return fndecl;
600 }
601
602
603
604 /* Initialize function decls for library functions. The external functions
605 are created as required. Builtin functions are added here. */
606
607 void
gfc_build_intrinsic_lib_fndecls(void)608 gfc_build_intrinsic_lib_fndecls (void)
609 {
610 gfc_intrinsic_map_t *m;
611 tree quad_decls[END_BUILTINS + 1];
612
613 if (gfc_real16_is_float128)
614 {
615 /* If we have soft-float types, we create the decls for their
616 C99-like library functions. For now, we only handle __float128
617 q-suffixed functions. */
618
619 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
620 tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
621
622 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
623
624 type = float128_type_node;
625 complex_type = complex_float128_type_node;
626 /* type (*) (type) */
627 func_1 = build_function_type_list (type, type, NULL_TREE);
628 /* int (*) (type) */
629 func_iround = build_function_type_list (integer_type_node,
630 type, NULL_TREE);
631 /* long (*) (type) */
632 func_lround = build_function_type_list (long_integer_type_node,
633 type, NULL_TREE);
634 /* long long (*) (type) */
635 func_llround = build_function_type_list (long_long_integer_type_node,
636 type, NULL_TREE);
637 /* type (*) (type, type) */
638 func_2 = build_function_type_list (type, type, type, NULL_TREE);
639 /* type (*) (type, &int) */
640 func_frexp
641 = build_function_type_list (type,
642 type,
643 build_pointer_type (integer_type_node),
644 NULL_TREE);
645 /* type (*) (type, int) */
646 func_scalbn = build_function_type_list (type,
647 type, integer_type_node, NULL_TREE);
648 /* type (*) (complex type) */
649 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
650 /* complex type (*) (complex type, complex type) */
651 func_cpow
652 = build_function_type_list (complex_type,
653 complex_type, complex_type, NULL_TREE);
654
655 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
656 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
657 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
658
659 /* Only these built-ins are actually needed here. These are used directly
660 from the code, when calling builtin_decl_for_precision() or
661 builtin_decl_for_float_type(). The others are all constructed by
662 gfc_get_intrinsic_lib_fndecl(). */
663 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
664 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
665
666 #include "mathbuiltins.def"
667
668 #undef OTHER_BUILTIN
669 #undef LIB_FUNCTION
670 #undef DEFINE_MATH_BUILTIN
671 #undef DEFINE_MATH_BUILTIN_C
672
673 /* There is one built-in we defined manually, because it gets called
674 with builtin_decl_for_precision() or builtin_decl_for_float_type()
675 even though it is not an OTHER_BUILTIN: it is SQRT. */
676 quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true);
677
678 }
679
680 /* Add GCC builtin functions. */
681 for (m = gfc_intrinsic_map;
682 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
683 {
684 if (m->float_built_in != END_BUILTINS)
685 m->real4_decl = builtin_decl_explicit (m->float_built_in);
686 if (m->complex_float_built_in != END_BUILTINS)
687 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
688 if (m->double_built_in != END_BUILTINS)
689 m->real8_decl = builtin_decl_explicit (m->double_built_in);
690 if (m->complex_double_built_in != END_BUILTINS)
691 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
692
693 /* If real(kind=10) exists, it is always long double. */
694 if (m->long_double_built_in != END_BUILTINS)
695 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
696 if (m->complex_long_double_built_in != END_BUILTINS)
697 m->complex10_decl
698 = builtin_decl_explicit (m->complex_long_double_built_in);
699
700 if (!gfc_real16_is_float128)
701 {
702 if (m->long_double_built_in != END_BUILTINS)
703 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
704 if (m->complex_long_double_built_in != END_BUILTINS)
705 m->complex16_decl
706 = builtin_decl_explicit (m->complex_long_double_built_in);
707 }
708 else if (quad_decls[m->double_built_in] != NULL_TREE)
709 {
710 /* Quad-precision function calls are constructed when first
711 needed by builtin_decl_for_precision(), except for those
712 that will be used directly (define by OTHER_BUILTIN). */
713 m->real16_decl = quad_decls[m->double_built_in];
714 }
715 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
716 {
717 /* Same thing for the complex ones. */
718 m->complex16_decl = quad_decls[m->double_built_in];
719 }
720 }
721 }
722
723
724 /* Create a fndecl for a simple intrinsic library function. */
725
726 static tree
gfc_get_intrinsic_lib_fndecl(gfc_intrinsic_map_t * m,gfc_expr * expr)727 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
728 {
729 tree type;
730 vec<tree, va_gc> *argtypes;
731 tree fndecl;
732 gfc_actual_arglist *actual;
733 tree *pdecl;
734 gfc_typespec *ts;
735 char name[GFC_MAX_SYMBOL_LEN + 3];
736
737 ts = &expr->ts;
738 if (ts->type == BT_REAL)
739 {
740 switch (ts->kind)
741 {
742 case 4:
743 pdecl = &m->real4_decl;
744 break;
745 case 8:
746 pdecl = &m->real8_decl;
747 break;
748 case 10:
749 pdecl = &m->real10_decl;
750 break;
751 case 16:
752 pdecl = &m->real16_decl;
753 break;
754 default:
755 gcc_unreachable ();
756 }
757 }
758 else if (ts->type == BT_COMPLEX)
759 {
760 gcc_assert (m->complex_available);
761
762 switch (ts->kind)
763 {
764 case 4:
765 pdecl = &m->complex4_decl;
766 break;
767 case 8:
768 pdecl = &m->complex8_decl;
769 break;
770 case 10:
771 pdecl = &m->complex10_decl;
772 break;
773 case 16:
774 pdecl = &m->complex16_decl;
775 break;
776 default:
777 gcc_unreachable ();
778 }
779 }
780 else
781 gcc_unreachable ();
782
783 if (*pdecl)
784 return *pdecl;
785
786 if (m->libm_name)
787 {
788 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
789 if (gfc_real_kinds[n].c_float)
790 snprintf (name, sizeof (name), "%s%s%s",
791 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
792 else if (gfc_real_kinds[n].c_double)
793 snprintf (name, sizeof (name), "%s%s",
794 ts->type == BT_COMPLEX ? "c" : "", m->name);
795 else if (gfc_real_kinds[n].c_long_double)
796 snprintf (name, sizeof (name), "%s%s%s",
797 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
798 else if (gfc_real_kinds[n].c_float128)
799 snprintf (name, sizeof (name), "%s%s%s",
800 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
801 else
802 gcc_unreachable ();
803 }
804 else
805 {
806 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
807 ts->type == BT_COMPLEX ? 'c' : 'r',
808 ts->kind);
809 }
810
811 argtypes = NULL;
812 for (actual = expr->value.function.actual; actual; actual = actual->next)
813 {
814 type = gfc_typenode_for_spec (&actual->expr->ts);
815 vec_safe_push (argtypes, type);
816 }
817 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
818 fndecl = build_decl (input_location,
819 FUNCTION_DECL, get_identifier (name), type);
820
821 /* Mark the decl as external. */
822 DECL_EXTERNAL (fndecl) = 1;
823 TREE_PUBLIC (fndecl) = 1;
824
825 /* Mark it __attribute__((const)), if possible. */
826 TREE_READONLY (fndecl) = m->is_constant;
827
828 rest_of_decl_compilation (fndecl, 1, 0);
829
830 (*pdecl) = fndecl;
831 return fndecl;
832 }
833
834
835 /* Convert an intrinsic function into an external or builtin call. */
836
837 static void
gfc_conv_intrinsic_lib_function(gfc_se * se,gfc_expr * expr)838 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
839 {
840 gfc_intrinsic_map_t *m;
841 tree fndecl;
842 tree rettype;
843 tree *args;
844 unsigned int num_args;
845 gfc_isym_id id;
846
847 id = expr->value.function.isym->id;
848 /* Find the entry for this function. */
849 for (m = gfc_intrinsic_map;
850 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
851 {
852 if (id == m->id)
853 break;
854 }
855
856 if (m->id == GFC_ISYM_NONE)
857 {
858 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
859 expr->value.function.name, id);
860 }
861
862 /* Get the decl and generate the call. */
863 num_args = gfc_intrinsic_argument_list_length (expr);
864 args = XALLOCAVEC (tree, num_args);
865
866 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
867 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
868 rettype = TREE_TYPE (TREE_TYPE (fndecl));
869
870 fndecl = build_addr (fndecl);
871 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
872 }
873
874
875 /* If bounds-checking is enabled, create code to verify at runtime that the
876 string lengths for both expressions are the same (needed for e.g. MERGE).
877 If bounds-checking is not enabled, does nothing. */
878
879 void
gfc_trans_same_strlen_check(const char * intr_name,locus * where,tree a,tree b,stmtblock_t * target)880 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
881 tree a, tree b, stmtblock_t* target)
882 {
883 tree cond;
884 tree name;
885
886 /* If bounds-checking is disabled, do nothing. */
887 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
888 return;
889
890 /* Compare the two string lengths. */
891 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
892
893 /* Output the runtime-check. */
894 name = gfc_build_cstring_const (intr_name);
895 name = gfc_build_addr_expr (pchar_type_node, name);
896 gfc_trans_runtime_check (true, false, cond, target, where,
897 "Unequal character lengths (%ld/%ld) in %s",
898 fold_convert (long_integer_type_node, a),
899 fold_convert (long_integer_type_node, b), name);
900 }
901
902
903 /* The EXPONENT(X) intrinsic function is translated into
904 int ret;
905 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
906 so that if X is a NaN or infinity, the result is HUGE(0).
907 */
908
909 static void
gfc_conv_intrinsic_exponent(gfc_se * se,gfc_expr * expr)910 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
911 {
912 tree arg, type, res, tmp, frexp, cond, huge;
913 int i;
914
915 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
916 expr->value.function.actual->expr->ts.kind);
917
918 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
919 arg = gfc_evaluate_now (arg, &se->pre);
920
921 i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
922 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
923 cond = build_call_expr_loc (input_location,
924 builtin_decl_explicit (BUILT_IN_ISFINITE),
925 1, arg);
926
927 res = gfc_create_var (integer_type_node, NULL);
928 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
929 gfc_build_addr_expr (NULL_TREE, res));
930 tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
931 tmp, res);
932 se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
933 cond, tmp, huge);
934
935 type = gfc_typenode_for_spec (&expr->ts);
936 se->expr = fold_convert (type, se->expr);
937 }
938
939
940 /* Fill in the following structure
941 struct caf_vector_t {
942 size_t nvec; // size of the vector
943 union {
944 struct {
945 void *vector;
946 int kind;
947 } v;
948 struct {
949 ptrdiff_t lower_bound;
950 ptrdiff_t upper_bound;
951 ptrdiff_t stride;
952 } triplet;
953 } u;
954 } */
955
956 static void
conv_caf_vector_subscript_elem(stmtblock_t * block,int i,tree desc,tree lower,tree upper,tree stride,tree vector,int kind,tree nvec)957 conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
958 tree lower, tree upper, tree stride,
959 tree vector, int kind, tree nvec)
960 {
961 tree field, type, tmp;
962
963 desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
964 type = TREE_TYPE (desc);
965
966 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
967 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
968 desc, field, NULL_TREE);
969 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
970
971 /* Access union. */
972 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
973 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
974 desc, field, NULL_TREE);
975 type = TREE_TYPE (desc);
976
977 /* Access the inner struct. */
978 field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
979 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
980 desc, field, NULL_TREE);
981 type = TREE_TYPE (desc);
982
983 if (vector != NULL_TREE)
984 {
985 /* Set dim.lower/upper/stride. */
986 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
987 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
988 desc, field, NULL_TREE);
989 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
990 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
991 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
992 desc, field, NULL_TREE);
993 gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
994 }
995 else
996 {
997 /* Set vector and kind. */
998 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
999 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1000 desc, field, NULL_TREE);
1001 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
1002
1003 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1004 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1005 desc, field, NULL_TREE);
1006 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1007
1008 field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1009 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1010 desc, field, NULL_TREE);
1011 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1012 }
1013 }
1014
1015
1016 static tree
conv_caf_vector_subscript(stmtblock_t * block,tree desc,gfc_array_ref * ar)1017 conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1018 {
1019 gfc_se argse;
1020 tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1021 tree lbound, ubound, tmp;
1022 int i;
1023
1024 var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1025
1026 for (i = 0; i < ar->dimen; i++)
1027 switch (ar->dimen_type[i])
1028 {
1029 case DIMEN_RANGE:
1030 if (ar->end[i])
1031 {
1032 gfc_init_se (&argse, NULL);
1033 gfc_conv_expr (&argse, ar->end[i]);
1034 gfc_add_block_to_block (block, &argse.pre);
1035 upper = gfc_evaluate_now (argse.expr, block);
1036 }
1037 else
1038 upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1039 if (ar->stride[i])
1040 {
1041 gfc_init_se (&argse, NULL);
1042 gfc_conv_expr (&argse, ar->stride[i]);
1043 gfc_add_block_to_block (block, &argse.pre);
1044 stride = gfc_evaluate_now (argse.expr, block);
1045 }
1046 else
1047 stride = gfc_index_one_node;
1048
1049 /* Fall through. */
1050 case DIMEN_ELEMENT:
1051 if (ar->start[i])
1052 {
1053 gfc_init_se (&argse, NULL);
1054 gfc_conv_expr (&argse, ar->start[i]);
1055 gfc_add_block_to_block (block, &argse.pre);
1056 lower = gfc_evaluate_now (argse.expr, block);
1057 }
1058 else
1059 lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1060 if (ar->dimen_type[i] == DIMEN_ELEMENT)
1061 {
1062 upper = lower;
1063 stride = gfc_index_one_node;
1064 }
1065 vector = NULL_TREE;
1066 nvec = size_zero_node;
1067 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1068 vector, 0, nvec);
1069 break;
1070
1071 case DIMEN_VECTOR:
1072 gfc_init_se (&argse, NULL);
1073 argse.descriptor_only = 1;
1074 gfc_conv_expr_descriptor (&argse, ar->start[i]);
1075 gfc_add_block_to_block (block, &argse.pre);
1076 vector = argse.expr;
1077 lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1078 ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1079 nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1080 tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1081 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1082 TREE_TYPE (nvec), nvec, tmp);
1083 lower = gfc_index_zero_node;
1084 upper = gfc_index_zero_node;
1085 stride = gfc_index_zero_node;
1086 vector = gfc_conv_descriptor_data_get (vector);
1087 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1088 vector, ar->start[i]->ts.kind, nvec);
1089 break;
1090 default:
1091 gcc_unreachable();
1092 }
1093 return gfc_build_addr_expr (NULL_TREE, var);
1094 }
1095
1096
1097 /* Get data from a remote coarray. */
1098
1099 static void
gfc_conv_intrinsic_caf_get(gfc_se * se,gfc_expr * expr,tree lhs,tree lhs_kind,tree may_require_tmp)1100 gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1101 tree may_require_tmp)
1102 {
1103 gfc_expr *array_expr;
1104 gfc_se argse;
1105 tree caf_decl, token, offset, image_index, tmp;
1106 tree res_var, dst_var, type, kind, vec;
1107
1108 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1109
1110 if (se->ss && se->ss->info->useflags)
1111 {
1112 /* Access the previously obtained result. */
1113 gfc_conv_tmp_array_ref (se);
1114 return;
1115 }
1116
1117 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1118 array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1119 type = gfc_typenode_for_spec (&array_expr->ts);
1120
1121 res_var = lhs;
1122 dst_var = lhs;
1123
1124 vec = null_pointer_node;
1125
1126 gfc_init_se (&argse, NULL);
1127 if (array_expr->rank == 0)
1128 {
1129 symbol_attribute attr;
1130
1131 gfc_clear_attr (&attr);
1132 gfc_conv_expr (&argse, array_expr);
1133
1134 if (lhs == NULL_TREE)
1135 {
1136 gfc_clear_attr (&attr);
1137 if (array_expr->ts.type == BT_CHARACTER)
1138 res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1139 argse.string_length);
1140 else
1141 res_var = gfc_create_var (type, "caf_res");
1142 dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1143 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1144 }
1145 argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1146 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1147 }
1148 else
1149 {
1150 /* If has_vector, pass descriptor for whole array and the
1151 vector bounds separately. */
1152 gfc_array_ref *ar, ar2;
1153 bool has_vector = false;
1154
1155 if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1156 {
1157 has_vector = true;
1158 ar = gfc_find_array_ref (expr);
1159 ar2 = *ar;
1160 memset (ar, '\0', sizeof (*ar));
1161 ar->as = ar2.as;
1162 ar->type = AR_FULL;
1163 }
1164 gfc_conv_expr_descriptor (&argse, array_expr);
1165 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1166 has the wrong type if component references are done. */
1167 gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1168 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1169 : array_expr->rank,
1170 type));
1171 if (has_vector)
1172 {
1173 vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1174 *ar = ar2;
1175 }
1176
1177 if (lhs == NULL_TREE)
1178 {
1179 /* Create temporary. */
1180 for (int n = 0; n < se->ss->loop->dimen; n++)
1181 if (se->loop->to[n] == NULL_TREE)
1182 {
1183 se->loop->from[n] =
1184 gfc_conv_descriptor_lbound_get (argse.expr, gfc_rank_cst[n]);
1185 se->loop->to[n] =
1186 gfc_conv_descriptor_ubound_get (argse.expr, gfc_rank_cst[n]);
1187 }
1188 gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1189 NULL_TREE, false, true, false,
1190 &array_expr->where);
1191 res_var = se->ss->info->data.array.descriptor;
1192 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1193 }
1194 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1195 }
1196
1197 kind = build_int_cst (integer_type_node, expr->ts.kind);
1198 if (lhs_kind == NULL_TREE)
1199 lhs_kind = kind;
1200
1201 gfc_add_block_to_block (&se->pre, &argse.pre);
1202 gfc_add_block_to_block (&se->post, &argse.post);
1203
1204 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1205 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1206 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1207 image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1208 gfc_get_caf_token_offset (&token, &offset, caf_decl, argse.expr, array_expr);
1209
1210 /* No overlap possible as we have generated a temporary. */
1211 if (lhs == NULL_TREE)
1212 may_require_tmp = boolean_false_node;
1213
1214 /* It guarantees memory consistency within the same segment */
1215 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1216 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1217 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1218 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1219 ASM_VOLATILE_P (tmp) = 1;
1220 gfc_add_expr_to_block (&se->pre, tmp);
1221
1222 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 9,
1223 token, offset, image_index, argse.expr, vec,
1224 dst_var, kind, lhs_kind, may_require_tmp);
1225 gfc_add_expr_to_block (&se->pre, tmp);
1226
1227 if (se->ss)
1228 gfc_advance_se_ss_chain (se);
1229
1230 se->expr = res_var;
1231 if (array_expr->ts.type == BT_CHARACTER)
1232 se->string_length = argse.string_length;
1233 }
1234
1235
1236 /* Send data to a remove coarray. */
1237
1238 static tree
conv_caf_send(gfc_code * code)1239 conv_caf_send (gfc_code *code) {
1240 gfc_expr *lhs_expr, *rhs_expr;
1241 gfc_se lhs_se, rhs_se;
1242 stmtblock_t block;
1243 tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1244 tree may_require_tmp;
1245 tree lhs_type = NULL_TREE;
1246 tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1247
1248 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1249
1250 lhs_expr = code->ext.actual->expr;
1251 rhs_expr = code->ext.actual->next->expr;
1252 may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
1253 ? boolean_false_node : boolean_true_node;
1254 gfc_init_block (&block);
1255
1256 /* LHS. */
1257 gfc_init_se (&lhs_se, NULL);
1258 if (lhs_expr->rank == 0)
1259 {
1260 symbol_attribute attr;
1261 gfc_clear_attr (&attr);
1262 gfc_conv_expr (&lhs_se, lhs_expr);
1263 lhs_type = TREE_TYPE (lhs_se.expr);
1264 lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
1265 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1266 }
1267 else
1268 {
1269 bool has_vector = gfc_has_vector_subscript (lhs_expr);
1270
1271 if (gfc_is_coindexed (lhs_expr) || !has_vector)
1272 {
1273 /* If has_vector, pass descriptor for whole array and the
1274 vector bounds separately. */
1275 gfc_array_ref *ar, ar2;
1276 bool has_tmp_lhs_array = false;
1277 if (has_vector)
1278 {
1279 has_tmp_lhs_array = true;
1280 ar = gfc_find_array_ref (lhs_expr);
1281 ar2 = *ar;
1282 memset (ar, '\0', sizeof (*ar));
1283 ar->as = ar2.as;
1284 ar->type = AR_FULL;
1285 }
1286 lhs_se.want_pointer = 1;
1287 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1288 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
1289 that has the wrong type if component references are done. */
1290 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1291 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1292 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1293 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1294 : lhs_expr->rank,
1295 lhs_type));
1296 if (has_tmp_lhs_array)
1297 {
1298 vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
1299 *ar = ar2;
1300 }
1301 }
1302 else
1303 {
1304 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
1305 indexed array expression. This is rewritten to:
1306
1307 tmp_array = arr2[...]
1308 arr1 ([...]) = tmp_array
1309
1310 because using the standard gfc_conv_expr (lhs_expr) did the
1311 assignment with lhs and rhs exchanged. */
1312
1313 gfc_ss *lss_for_tmparray, *lss_real;
1314 gfc_loopinfo loop;
1315 gfc_se se;
1316 stmtblock_t body;
1317 tree tmparr_desc, src;
1318 tree index = gfc_index_zero_node;
1319 tree stride = gfc_index_zero_node;
1320 int n;
1321
1322 /* Walk both sides of the assignment, once to get the shape of the
1323 temporary array to create right. */
1324 lss_for_tmparray = gfc_walk_expr (lhs_expr);
1325 /* And a second time to be able to create an assignment of the
1326 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
1327 the tree in the descriptor with the one for the temporary
1328 array. */
1329 lss_real = gfc_walk_expr (lhs_expr);
1330 gfc_init_loopinfo (&loop);
1331 gfc_add_ss_to_loop (&loop, lss_for_tmparray);
1332 gfc_add_ss_to_loop (&loop, lss_real);
1333 gfc_conv_ss_startstride (&loop);
1334 gfc_conv_loop_setup (&loop, &lhs_expr->where);
1335 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1336 gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
1337 lss_for_tmparray, lhs_type, NULL_TREE,
1338 false, true, false,
1339 &lhs_expr->where);
1340 tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
1341 gfc_start_scalarized_body (&loop, &body);
1342 gfc_init_se (&se, NULL);
1343 gfc_copy_loopinfo_to_se (&se, &loop);
1344 se.ss = lss_real;
1345 gfc_conv_expr (&se, lhs_expr);
1346 gfc_add_block_to_block (&body, &se.pre);
1347
1348 /* Walk over all indexes of the loop. */
1349 for (n = loop.dimen - 1; n > 0; --n)
1350 {
1351 tmp = loop.loopvar[n];
1352 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1353 gfc_array_index_type, tmp, loop.from[n]);
1354 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1355 gfc_array_index_type, tmp, index);
1356
1357 stride = fold_build2_loc (input_location, MINUS_EXPR,
1358 gfc_array_index_type,
1359 loop.to[n - 1], loop.from[n - 1]);
1360 stride = fold_build2_loc (input_location, PLUS_EXPR,
1361 gfc_array_index_type,
1362 stride, gfc_index_one_node);
1363
1364 index = fold_build2_loc (input_location, MULT_EXPR,
1365 gfc_array_index_type, tmp, stride);
1366 }
1367
1368 index = fold_build2_loc (input_location, MINUS_EXPR,
1369 gfc_array_index_type,
1370 index, loop.from[0]);
1371
1372 index = fold_build2_loc (input_location, PLUS_EXPR,
1373 gfc_array_index_type,
1374 loop.loopvar[0], index);
1375
1376 src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
1377 src = gfc_build_array_ref (src, index, NULL);
1378 /* Now create the assignment of lhs_expr = tmp_array. */
1379 gfc_add_modify (&body, se.expr, src);
1380 gfc_add_block_to_block (&body, &se.post);
1381 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
1382 gfc_trans_scalarizing_loops (&loop, &body);
1383 gfc_add_block_to_block (&loop.pre, &loop.post);
1384 gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
1385 gfc_free_ss (lss_for_tmparray);
1386 gfc_free_ss (lss_real);
1387 }
1388 }
1389
1390 lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
1391 gfc_add_block_to_block (&block, &lhs_se.pre);
1392
1393 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1394 temporary and a loop. */
1395 if (!gfc_is_coindexed (lhs_expr))
1396 {
1397 gcc_assert (gfc_is_coindexed (rhs_expr));
1398 gfc_init_se (&rhs_se, NULL);
1399 gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
1400 may_require_tmp);
1401 gfc_add_block_to_block (&block, &rhs_se.pre);
1402 gfc_add_block_to_block (&block, &rhs_se.post);
1403 gfc_add_block_to_block (&block, &lhs_se.post);
1404 return gfc_finish_block (&block);
1405 }
1406
1407 /* Obtain token, offset and image index for the LHS. */
1408
1409 caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1410 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1411 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1412 image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1413 gfc_get_caf_token_offset (&token, &offset, caf_decl, lhs_se.expr, lhs_expr);
1414
1415 /* RHS. */
1416 gfc_init_se (&rhs_se, NULL);
1417 if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
1418 && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
1419 rhs_expr = rhs_expr->value.function.actual->expr;
1420 if (rhs_expr->rank == 0)
1421 {
1422 symbol_attribute attr;
1423 gfc_clear_attr (&attr);
1424 gfc_conv_expr (&rhs_se, rhs_expr);
1425 if (!gfc_is_coindexed (rhs_expr) && rhs_expr->ts.type != BT_CHARACTER)
1426 rhs_se.expr = fold_convert (lhs_type , rhs_se.expr);
1427 rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
1428 rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
1429 }
1430 else
1431 {
1432 /* If has_vector, pass descriptor for whole array and the
1433 vector bounds separately. */
1434 gfc_array_ref *ar, ar2;
1435 bool has_vector = false;
1436 tree tmp2;
1437
1438 if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
1439 {
1440 has_vector = true;
1441 ar = gfc_find_array_ref (rhs_expr);
1442 ar2 = *ar;
1443 memset (ar, '\0', sizeof (*ar));
1444 ar->as = ar2.as;
1445 ar->type = AR_FULL;
1446 }
1447 rhs_se.want_pointer = 1;
1448 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1449 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1450 has the wrong type if component references are done. */
1451 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
1452 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
1453 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1454 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1455 : rhs_expr->rank,
1456 tmp2));
1457 if (has_vector)
1458 {
1459 rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
1460 *ar = ar2;
1461 }
1462 }
1463
1464 gfc_add_block_to_block (&block, &rhs_se.pre);
1465
1466 rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
1467
1468 if (!gfc_is_coindexed (rhs_expr))
1469 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 9, token,
1470 offset, image_index, lhs_se.expr, vec,
1471 rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp);
1472 else
1473 {
1474 tree rhs_token, rhs_offset, rhs_image_index;
1475
1476 /* It guarantees memory consistency within the same segment */
1477 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1478 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1479 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1480 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1481 ASM_VOLATILE_P (tmp) = 1;
1482 gfc_add_expr_to_block (&block, tmp);
1483
1484 caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
1485 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1486 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1487 rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
1488 gfc_get_caf_token_offset (&rhs_token, &rhs_offset, caf_decl, rhs_se.expr,
1489 rhs_expr);
1490 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, 13,
1491 token, offset, image_index, lhs_se.expr, vec,
1492 rhs_token, rhs_offset, rhs_image_index,
1493 rhs_se.expr, rhs_vec, lhs_kind, rhs_kind,
1494 may_require_tmp);
1495 }
1496 gfc_add_expr_to_block (&block, tmp);
1497 gfc_add_block_to_block (&block, &lhs_se.post);
1498 gfc_add_block_to_block (&block, &rhs_se.post);
1499
1500 /* It guarantees memory consistency within the same segment */
1501 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1502 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1503 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1504 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1505 ASM_VOLATILE_P (tmp) = 1;
1506 gfc_add_expr_to_block (&block, tmp);
1507
1508 return gfc_finish_block (&block);
1509 }
1510
1511
1512 static void
trans_this_image(gfc_se * se,gfc_expr * expr)1513 trans_this_image (gfc_se * se, gfc_expr *expr)
1514 {
1515 stmtblock_t loop;
1516 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
1517 lbound, ubound, extent, ml;
1518 gfc_se argse;
1519 int rank, corank;
1520 gfc_expr *distance = expr->value.function.actual->next->next->expr;
1521
1522 if (expr->value.function.actual->expr
1523 && !gfc_is_coarray (expr->value.function.actual->expr))
1524 distance = expr->value.function.actual->expr;
1525
1526 /* The case -fcoarray=single is handled elsewhere. */
1527 gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1528
1529 /* Argument-free version: THIS_IMAGE(). */
1530 if (distance || expr->value.function.actual->expr == NULL)
1531 {
1532 if (distance)
1533 {
1534 gfc_init_se (&argse, NULL);
1535 gfc_conv_expr_val (&argse, distance);
1536 gfc_add_block_to_block (&se->pre, &argse.pre);
1537 gfc_add_block_to_block (&se->post, &argse.post);
1538 tmp = fold_convert (integer_type_node, argse.expr);
1539 }
1540 else
1541 tmp = integer_zero_node;
1542 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1543 tmp);
1544 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1545 tmp);
1546 return;
1547 }
1548
1549 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1550
1551 type = gfc_get_int_type (gfc_default_integer_kind);
1552 corank = gfc_get_corank (expr->value.function.actual->expr);
1553 rank = expr->value.function.actual->expr->rank;
1554
1555 /* Obtain the descriptor of the COARRAY. */
1556 gfc_init_se (&argse, NULL);
1557 argse.want_coarray = 1;
1558 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1559 gfc_add_block_to_block (&se->pre, &argse.pre);
1560 gfc_add_block_to_block (&se->post, &argse.post);
1561 desc = argse.expr;
1562
1563 if (se->ss)
1564 {
1565 /* Create an implicit second parameter from the loop variable. */
1566 gcc_assert (!expr->value.function.actual->next->expr);
1567 gcc_assert (corank > 0);
1568 gcc_assert (se->loop->dimen == 1);
1569 gcc_assert (se->ss->info->expr == expr);
1570
1571 dim_arg = se->loop->loopvar[0];
1572 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1573 gfc_array_index_type, dim_arg,
1574 build_int_cst (TREE_TYPE (dim_arg), 1));
1575 gfc_advance_se_ss_chain (se);
1576 }
1577 else
1578 {
1579 /* Use the passed DIM= argument. */
1580 gcc_assert (expr->value.function.actual->next->expr);
1581 gfc_init_se (&argse, NULL);
1582 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1583 gfc_array_index_type);
1584 gfc_add_block_to_block (&se->pre, &argse.pre);
1585 dim_arg = argse.expr;
1586
1587 if (INTEGER_CST_P (dim_arg))
1588 {
1589 if (wi::ltu_p (dim_arg, 1)
1590 || wi::gtu_p (dim_arg, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1591 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1592 "dimension index", expr->value.function.isym->name,
1593 &expr->where);
1594 }
1595 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1596 {
1597 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1598 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1599 dim_arg,
1600 build_int_cst (TREE_TYPE (dim_arg), 1));
1601 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1602 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1603 dim_arg, tmp);
1604 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1605 boolean_type_node, cond, tmp);
1606 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1607 gfc_msg_fault);
1608 }
1609 }
1610
1611 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1612 one always has a dim_arg argument.
1613
1614 m = this_image() - 1
1615 if (corank == 1)
1616 {
1617 sub(1) = m + lcobound(corank)
1618 return;
1619 }
1620 i = rank
1621 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1622 for (;;)
1623 {
1624 extent = gfc_extent(i)
1625 ml = m
1626 m = m/extent
1627 if (i >= min_var)
1628 goto exit_label
1629 i++
1630 }
1631 exit_label:
1632 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1633 : m + lcobound(corank)
1634 */
1635
1636 /* this_image () - 1. */
1637 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1638 integer_zero_node);
1639 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
1640 fold_convert (type, tmp), build_int_cst (type, 1));
1641 if (corank == 1)
1642 {
1643 /* sub(1) = m + lcobound(corank). */
1644 lbound = gfc_conv_descriptor_lbound_get (desc,
1645 build_int_cst (TREE_TYPE (gfc_array_index_type),
1646 corank+rank-1));
1647 lbound = fold_convert (type, lbound);
1648 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1649
1650 se->expr = tmp;
1651 return;
1652 }
1653
1654 m = gfc_create_var (type, NULL);
1655 ml = gfc_create_var (type, NULL);
1656 loop_var = gfc_create_var (integer_type_node, NULL);
1657 min_var = gfc_create_var (integer_type_node, NULL);
1658
1659 /* m = this_image () - 1. */
1660 gfc_add_modify (&se->pre, m, tmp);
1661
1662 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1663 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1664 fold_convert (integer_type_node, dim_arg),
1665 build_int_cst (integer_type_node, rank - 1));
1666 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1667 build_int_cst (integer_type_node, rank + corank - 2),
1668 tmp);
1669 gfc_add_modify (&se->pre, min_var, tmp);
1670
1671 /* i = rank. */
1672 tmp = build_int_cst (integer_type_node, rank);
1673 gfc_add_modify (&se->pre, loop_var, tmp);
1674
1675 exit_label = gfc_build_label_decl (NULL_TREE);
1676 TREE_USED (exit_label) = 1;
1677
1678 /* Loop body. */
1679 gfc_init_block (&loop);
1680
1681 /* ml = m. */
1682 gfc_add_modify (&loop, ml, m);
1683
1684 /* extent = ... */
1685 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1686 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1687 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1688 extent = fold_convert (type, extent);
1689
1690 /* m = m/extent. */
1691 gfc_add_modify (&loop, m,
1692 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
1693 m, extent));
1694
1695 /* Exit condition: if (i >= min_var) goto exit_label. */
1696 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
1697 min_var);
1698 tmp = build1_v (GOTO_EXPR, exit_label);
1699 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1700 build_empty_stmt (input_location));
1701 gfc_add_expr_to_block (&loop, tmp);
1702
1703 /* Increment loop variable: i++. */
1704 gfc_add_modify (&loop, loop_var,
1705 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1706 loop_var,
1707 build_int_cst (integer_type_node, 1)));
1708
1709 /* Making the loop... actually loop! */
1710 tmp = gfc_finish_block (&loop);
1711 tmp = build1_v (LOOP_EXPR, tmp);
1712 gfc_add_expr_to_block (&se->pre, tmp);
1713
1714 /* The exit label. */
1715 tmp = build1_v (LABEL_EXPR, exit_label);
1716 gfc_add_expr_to_block (&se->pre, tmp);
1717
1718 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1719 : m + lcobound(corank) */
1720
1721 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
1722 build_int_cst (TREE_TYPE (dim_arg), corank));
1723
1724 lbound = gfc_conv_descriptor_lbound_get (desc,
1725 fold_build2_loc (input_location, PLUS_EXPR,
1726 gfc_array_index_type, dim_arg,
1727 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
1728 lbound = fold_convert (type, lbound);
1729
1730 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
1731 fold_build2_loc (input_location, MULT_EXPR, type,
1732 m, extent));
1733 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1734
1735 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
1736 fold_build2_loc (input_location, PLUS_EXPR, type,
1737 m, lbound));
1738 }
1739
1740
1741 static void
trans_image_index(gfc_se * se,gfc_expr * expr)1742 trans_image_index (gfc_se * se, gfc_expr *expr)
1743 {
1744 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
1745 tmp, invalid_bound;
1746 gfc_se argse, subse;
1747 int rank, corank, codim;
1748
1749 type = gfc_get_int_type (gfc_default_integer_kind);
1750 corank = gfc_get_corank (expr->value.function.actual->expr);
1751 rank = expr->value.function.actual->expr->rank;
1752
1753 /* Obtain the descriptor of the COARRAY. */
1754 gfc_init_se (&argse, NULL);
1755 argse.want_coarray = 1;
1756 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1757 gfc_add_block_to_block (&se->pre, &argse.pre);
1758 gfc_add_block_to_block (&se->post, &argse.post);
1759 desc = argse.expr;
1760
1761 /* Obtain a handle to the SUB argument. */
1762 gfc_init_se (&subse, NULL);
1763 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
1764 gfc_add_block_to_block (&se->pre, &subse.pre);
1765 gfc_add_block_to_block (&se->post, &subse.post);
1766 subdesc = build_fold_indirect_ref_loc (input_location,
1767 gfc_conv_descriptor_data_get (subse.expr));
1768
1769 /* Fortran 2008 does not require that the values remain in the cobounds,
1770 thus we need explicitly check this - and return 0 if they are exceeded. */
1771
1772 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1773 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
1774 invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1775 fold_convert (gfc_array_index_type, tmp),
1776 lbound);
1777
1778 for (codim = corank + rank - 2; codim >= rank; codim--)
1779 {
1780 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1781 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1782 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1783 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1784 fold_convert (gfc_array_index_type, tmp),
1785 lbound);
1786 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1787 boolean_type_node, invalid_bound, cond);
1788 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1789 fold_convert (gfc_array_index_type, tmp),
1790 ubound);
1791 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1792 boolean_type_node, invalid_bound, cond);
1793 }
1794
1795 invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
1796
1797 /* See Fortran 2008, C.10 for the following algorithm. */
1798
1799 /* coindex = sub(corank) - lcobound(n). */
1800 coindex = fold_convert (gfc_array_index_type,
1801 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
1802 NULL));
1803 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1804 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1805 fold_convert (gfc_array_index_type, coindex),
1806 lbound);
1807
1808 for (codim = corank + rank - 2; codim >= rank; codim--)
1809 {
1810 tree extent, ubound;
1811
1812 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1813 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1814 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1815 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1816
1817 /* coindex *= extent. */
1818 coindex = fold_build2_loc (input_location, MULT_EXPR,
1819 gfc_array_index_type, coindex, extent);
1820
1821 /* coindex += sub(codim). */
1822 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1823 coindex = fold_build2_loc (input_location, PLUS_EXPR,
1824 gfc_array_index_type, coindex,
1825 fold_convert (gfc_array_index_type, tmp));
1826
1827 /* coindex -= lbound(codim). */
1828 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1829 coindex = fold_build2_loc (input_location, MINUS_EXPR,
1830 gfc_array_index_type, coindex, lbound);
1831 }
1832
1833 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
1834 fold_convert(type, coindex),
1835 build_int_cst (type, 1));
1836
1837 /* Return 0 if "coindex" exceeds num_images(). */
1838
1839 if (flag_coarray == GFC_FCOARRAY_SINGLE)
1840 num_images = build_int_cst (type, 1);
1841 else
1842 {
1843 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
1844 integer_zero_node,
1845 build_int_cst (integer_type_node, -1));
1846 num_images = fold_convert (type, tmp);
1847 }
1848
1849 tmp = gfc_create_var (type, NULL);
1850 gfc_add_modify (&se->pre, tmp, coindex);
1851
1852 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1853 num_images);
1854 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
1855 cond,
1856 fold_convert (boolean_type_node, invalid_bound));
1857 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
1858 build_int_cst (type, 0), tmp);
1859 }
1860
1861
1862 static void
trans_num_images(gfc_se * se,gfc_expr * expr)1863 trans_num_images (gfc_se * se, gfc_expr *expr)
1864 {
1865 tree tmp, distance, failed;
1866 gfc_se argse;
1867
1868 if (expr->value.function.actual->expr)
1869 {
1870 gfc_init_se (&argse, NULL);
1871 gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
1872 gfc_add_block_to_block (&se->pre, &argse.pre);
1873 gfc_add_block_to_block (&se->post, &argse.post);
1874 distance = fold_convert (integer_type_node, argse.expr);
1875 }
1876 else
1877 distance = integer_zero_node;
1878
1879 if (expr->value.function.actual->next->expr)
1880 {
1881 gfc_init_se (&argse, NULL);
1882 gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
1883 gfc_add_block_to_block (&se->pre, &argse.pre);
1884 gfc_add_block_to_block (&se->post, &argse.post);
1885 failed = fold_convert (integer_type_node, argse.expr);
1886 }
1887 else
1888 failed = build_int_cst (integer_type_node, -1);
1889
1890 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
1891 distance, failed);
1892 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
1893 }
1894
1895
1896 static void
gfc_conv_intrinsic_rank(gfc_se * se,gfc_expr * expr)1897 gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
1898 {
1899 gfc_se argse;
1900
1901 gfc_init_se (&argse, NULL);
1902 argse.data_not_needed = 1;
1903 argse.descriptor_only = 1;
1904
1905 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1906 gfc_add_block_to_block (&se->pre, &argse.pre);
1907 gfc_add_block_to_block (&se->post, &argse.post);
1908
1909 se->expr = gfc_conv_descriptor_rank (argse.expr);
1910 }
1911
1912
1913 /* Evaluate a single upper or lower bound. */
1914 /* TODO: bound intrinsic generates way too much unnecessary code. */
1915
1916 static void
gfc_conv_intrinsic_bound(gfc_se * se,gfc_expr * expr,int upper)1917 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
1918 {
1919 gfc_actual_arglist *arg;
1920 gfc_actual_arglist *arg2;
1921 tree desc;
1922 tree type;
1923 tree bound;
1924 tree tmp;
1925 tree cond, cond1, cond3, cond4, size;
1926 tree ubound;
1927 tree lbound;
1928 gfc_se argse;
1929 gfc_array_spec * as;
1930 bool assumed_rank_lb_one;
1931
1932 arg = expr->value.function.actual;
1933 arg2 = arg->next;
1934
1935 if (se->ss)
1936 {
1937 /* Create an implicit second parameter from the loop variable. */
1938 gcc_assert (!arg2->expr);
1939 gcc_assert (se->loop->dimen == 1);
1940 gcc_assert (se->ss->info->expr == expr);
1941 gfc_advance_se_ss_chain (se);
1942 bound = se->loop->loopvar[0];
1943 bound = fold_build2_loc (input_location, MINUS_EXPR,
1944 gfc_array_index_type, bound,
1945 se->loop->from[0]);
1946 }
1947 else
1948 {
1949 /* use the passed argument. */
1950 gcc_assert (arg2->expr);
1951 gfc_init_se (&argse, NULL);
1952 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1953 gfc_add_block_to_block (&se->pre, &argse.pre);
1954 bound = argse.expr;
1955 /* Convert from one based to zero based. */
1956 bound = fold_build2_loc (input_location, MINUS_EXPR,
1957 gfc_array_index_type, bound,
1958 gfc_index_one_node);
1959 }
1960
1961 /* TODO: don't re-evaluate the descriptor on each iteration. */
1962 /* Get a descriptor for the first parameter. */
1963 gfc_init_se (&argse, NULL);
1964 gfc_conv_expr_descriptor (&argse, arg->expr);
1965 gfc_add_block_to_block (&se->pre, &argse.pre);
1966 gfc_add_block_to_block (&se->post, &argse.post);
1967
1968 desc = argse.expr;
1969
1970 as = gfc_get_full_arrayspec_from_expr (arg->expr);
1971
1972 if (INTEGER_CST_P (bound))
1973 {
1974 if (((!as || as->type != AS_ASSUMED_RANK)
1975 && wi::geu_p (bound, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
1976 || wi::gtu_p (bound, GFC_MAX_DIMENSIONS))
1977 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1978 "dimension index", upper ? "UBOUND" : "LBOUND",
1979 &expr->where);
1980 }
1981
1982 if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
1983 {
1984 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1985 {
1986 bound = gfc_evaluate_now (bound, &se->pre);
1987 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1988 bound, build_int_cst (TREE_TYPE (bound), 0));
1989 if (as && as->type == AS_ASSUMED_RANK)
1990 tmp = gfc_conv_descriptor_rank (desc);
1991 else
1992 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
1993 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1994 bound, fold_convert(TREE_TYPE (bound), tmp));
1995 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1996 boolean_type_node, cond, tmp);
1997 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1998 gfc_msg_fault);
1999 }
2000 }
2001
2002 /* Take care of the lbound shift for assumed-rank arrays, which are
2003 nonallocatable and nonpointers. Those has a lbound of 1. */
2004 assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2005 && ((arg->expr->ts.type != BT_CLASS
2006 && !arg->expr->symtree->n.sym->attr.allocatable
2007 && !arg->expr->symtree->n.sym->attr.pointer)
2008 || (arg->expr->ts.type == BT_CLASS
2009 && !CLASS_DATA (arg->expr)->attr.allocatable
2010 && !CLASS_DATA (arg->expr)->attr.class_pointer));
2011
2012 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2013 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2014
2015 /* 13.14.53: Result value for LBOUND
2016
2017 Case (i): For an array section or for an array expression other than a
2018 whole array or array structure component, LBOUND(ARRAY, DIM)
2019 has the value 1. For a whole array or array structure
2020 component, LBOUND(ARRAY, DIM) has the value:
2021 (a) equal to the lower bound for subscript DIM of ARRAY if
2022 dimension DIM of ARRAY does not have extent zero
2023 or if ARRAY is an assumed-size array of rank DIM,
2024 or (b) 1 otherwise.
2025
2026 13.14.113: Result value for UBOUND
2027
2028 Case (i): For an array section or for an array expression other than a
2029 whole array or array structure component, UBOUND(ARRAY, DIM)
2030 has the value equal to the number of elements in the given
2031 dimension; otherwise, it has a value equal to the upper bound
2032 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2033 not have size zero and has value zero if dimension DIM has
2034 size zero. */
2035
2036 if (!upper && assumed_rank_lb_one)
2037 se->expr = gfc_index_one_node;
2038 else if (as)
2039 {
2040 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
2041
2042 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2043 ubound, lbound);
2044 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2045 stride, gfc_index_zero_node);
2046 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2047 boolean_type_node, cond3, cond1);
2048 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2049 stride, gfc_index_zero_node);
2050
2051 if (upper)
2052 {
2053 tree cond5;
2054 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2055 boolean_type_node, cond3, cond4);
2056 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2057 gfc_index_one_node, lbound);
2058 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2059 boolean_type_node, cond4, cond5);
2060
2061 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2062 boolean_type_node, cond, cond5);
2063
2064 if (assumed_rank_lb_one)
2065 {
2066 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2067 gfc_array_index_type, ubound, lbound);
2068 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2069 gfc_array_index_type, tmp, gfc_index_one_node);
2070 }
2071 else
2072 tmp = ubound;
2073
2074 se->expr = fold_build3_loc (input_location, COND_EXPR,
2075 gfc_array_index_type, cond,
2076 tmp, gfc_index_zero_node);
2077 }
2078 else
2079 {
2080 if (as->type == AS_ASSUMED_SIZE)
2081 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2082 bound, build_int_cst (TREE_TYPE (bound),
2083 arg->expr->rank - 1));
2084 else
2085 cond = boolean_false_node;
2086
2087 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2088 boolean_type_node, cond3, cond4);
2089 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2090 boolean_type_node, cond, cond1);
2091
2092 se->expr = fold_build3_loc (input_location, COND_EXPR,
2093 gfc_array_index_type, cond,
2094 lbound, gfc_index_one_node);
2095 }
2096 }
2097 else
2098 {
2099 if (upper)
2100 {
2101 size = fold_build2_loc (input_location, MINUS_EXPR,
2102 gfc_array_index_type, ubound, lbound);
2103 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2104 gfc_array_index_type, size,
2105 gfc_index_one_node);
2106 se->expr = fold_build2_loc (input_location, MAX_EXPR,
2107 gfc_array_index_type, se->expr,
2108 gfc_index_zero_node);
2109 }
2110 else
2111 se->expr = gfc_index_one_node;
2112 }
2113
2114 type = gfc_typenode_for_spec (&expr->ts);
2115 se->expr = convert (type, se->expr);
2116 }
2117
2118
2119 static void
conv_intrinsic_cobound(gfc_se * se,gfc_expr * expr)2120 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2121 {
2122 gfc_actual_arglist *arg;
2123 gfc_actual_arglist *arg2;
2124 gfc_se argse;
2125 tree bound, resbound, resbound2, desc, cond, tmp;
2126 tree type;
2127 int corank;
2128
2129 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2130 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2131 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2132
2133 arg = expr->value.function.actual;
2134 arg2 = arg->next;
2135
2136 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2137 corank = gfc_get_corank (arg->expr);
2138
2139 gfc_init_se (&argse, NULL);
2140 argse.want_coarray = 1;
2141
2142 gfc_conv_expr_descriptor (&argse, arg->expr);
2143 gfc_add_block_to_block (&se->pre, &argse.pre);
2144 gfc_add_block_to_block (&se->post, &argse.post);
2145 desc = argse.expr;
2146
2147 if (se->ss)
2148 {
2149 /* Create an implicit second parameter from the loop variable. */
2150 gcc_assert (!arg2->expr);
2151 gcc_assert (corank > 0);
2152 gcc_assert (se->loop->dimen == 1);
2153 gcc_assert (se->ss->info->expr == expr);
2154
2155 bound = se->loop->loopvar[0];
2156 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2157 bound, gfc_rank_cst[arg->expr->rank]);
2158 gfc_advance_se_ss_chain (se);
2159 }
2160 else
2161 {
2162 /* use the passed argument. */
2163 gcc_assert (arg2->expr);
2164 gfc_init_se (&argse, NULL);
2165 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2166 gfc_add_block_to_block (&se->pre, &argse.pre);
2167 bound = argse.expr;
2168
2169 if (INTEGER_CST_P (bound))
2170 {
2171 if (wi::ltu_p (bound, 1)
2172 || wi::gtu_p (bound, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2173 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2174 "dimension index", expr->value.function.isym->name,
2175 &expr->where);
2176 }
2177 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2178 {
2179 bound = gfc_evaluate_now (bound, &se->pre);
2180 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2181 bound, build_int_cst (TREE_TYPE (bound), 1));
2182 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2183 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2184 bound, tmp);
2185 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2186 boolean_type_node, cond, tmp);
2187 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2188 gfc_msg_fault);
2189 }
2190
2191
2192 /* Subtract 1 to get to zero based and add dimensions. */
2193 switch (arg->expr->rank)
2194 {
2195 case 0:
2196 bound = fold_build2_loc (input_location, MINUS_EXPR,
2197 gfc_array_index_type, bound,
2198 gfc_index_one_node);
2199 case 1:
2200 break;
2201 default:
2202 bound = fold_build2_loc (input_location, PLUS_EXPR,
2203 gfc_array_index_type, bound,
2204 gfc_rank_cst[arg->expr->rank - 1]);
2205 }
2206 }
2207
2208 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2209
2210 /* Handle UCOBOUND with special handling of the last codimension. */
2211 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
2212 {
2213 /* Last codimension: For -fcoarray=single just return
2214 the lcobound - otherwise add
2215 ceiling (real (num_images ()) / real (size)) - 1
2216 = (num_images () + size - 1) / size - 1
2217 = (num_images - 1) / size(),
2218 where size is the product of the extent of all but the last
2219 codimension. */
2220
2221 if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2222 {
2223 tree cosize;
2224
2225 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2226 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2227 2, integer_zero_node,
2228 build_int_cst (integer_type_node, -1));
2229 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2230 gfc_array_index_type,
2231 fold_convert (gfc_array_index_type, tmp),
2232 build_int_cst (gfc_array_index_type, 1));
2233 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2234 gfc_array_index_type, tmp,
2235 fold_convert (gfc_array_index_type, cosize));
2236 resbound = fold_build2_loc (input_location, PLUS_EXPR,
2237 gfc_array_index_type, resbound, tmp);
2238 }
2239 else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2240 {
2241 /* ubound = lbound + num_images() - 1. */
2242 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2243 2, integer_zero_node,
2244 build_int_cst (integer_type_node, -1));
2245 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2246 gfc_array_index_type,
2247 fold_convert (gfc_array_index_type, tmp),
2248 build_int_cst (gfc_array_index_type, 1));
2249 resbound = fold_build2_loc (input_location, PLUS_EXPR,
2250 gfc_array_index_type, resbound, tmp);
2251 }
2252
2253 if (corank > 1)
2254 {
2255 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2256 bound,
2257 build_int_cst (TREE_TYPE (bound),
2258 arg->expr->rank + corank - 1));
2259
2260 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2261 se->expr = fold_build3_loc (input_location, COND_EXPR,
2262 gfc_array_index_type, cond,
2263 resbound, resbound2);
2264 }
2265 else
2266 se->expr = resbound;
2267 }
2268 else
2269 se->expr = resbound;
2270
2271 type = gfc_typenode_for_spec (&expr->ts);
2272 se->expr = convert (type, se->expr);
2273 }
2274
2275
2276 static void
conv_intrinsic_stride(gfc_se * se,gfc_expr * expr)2277 conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2278 {
2279 gfc_actual_arglist *array_arg;
2280 gfc_actual_arglist *dim_arg;
2281 gfc_se argse;
2282 tree desc, tmp;
2283
2284 array_arg = expr->value.function.actual;
2285 dim_arg = array_arg->next;
2286
2287 gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2288
2289 gfc_init_se (&argse, NULL);
2290 gfc_conv_expr_descriptor (&argse, array_arg->expr);
2291 gfc_add_block_to_block (&se->pre, &argse.pre);
2292 gfc_add_block_to_block (&se->post, &argse.post);
2293 desc = argse.expr;
2294
2295 gcc_assert (dim_arg->expr);
2296 gfc_init_se (&argse, NULL);
2297 gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2298 gfc_add_block_to_block (&se->pre, &argse.pre);
2299 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2300 argse.expr, gfc_index_one_node);
2301 se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2302 }
2303
2304
2305 static void
gfc_conv_intrinsic_abs(gfc_se * se,gfc_expr * expr)2306 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2307 {
2308 tree arg, cabs;
2309
2310 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2311
2312 switch (expr->value.function.actual->expr->ts.type)
2313 {
2314 case BT_INTEGER:
2315 case BT_REAL:
2316 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2317 arg);
2318 break;
2319
2320 case BT_COMPLEX:
2321 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2322 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2323 break;
2324
2325 default:
2326 gcc_unreachable ();
2327 }
2328 }
2329
2330
2331 /* Create a complex value from one or two real components. */
2332
2333 static void
gfc_conv_intrinsic_cmplx(gfc_se * se,gfc_expr * expr,int both)2334 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2335 {
2336 tree real;
2337 tree imag;
2338 tree type;
2339 tree *args;
2340 unsigned int num_args;
2341
2342 num_args = gfc_intrinsic_argument_list_length (expr);
2343 args = XALLOCAVEC (tree, num_args);
2344
2345 type = gfc_typenode_for_spec (&expr->ts);
2346 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2347 real = convert (TREE_TYPE (type), args[0]);
2348 if (both)
2349 imag = convert (TREE_TYPE (type), args[1]);
2350 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2351 {
2352 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2353 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2354 imag = convert (TREE_TYPE (type), imag);
2355 }
2356 else
2357 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2358
2359 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2360 }
2361
2362
2363 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2364 MODULO(A, P) = A - FLOOR (A / P) * P
2365
2366 The obvious algorithms above are numerically instable for large
2367 arguments, hence these intrinsics are instead implemented via calls
2368 to the fmod family of functions. It is the responsibility of the
2369 user to ensure that the second argument is non-zero. */
2370
2371 static void
gfc_conv_intrinsic_mod(gfc_se * se,gfc_expr * expr,int modulo)2372 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2373 {
2374 tree type;
2375 tree tmp;
2376 tree test;
2377 tree test2;
2378 tree fmod;
2379 tree zero;
2380 tree args[2];
2381
2382 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2383
2384 switch (expr->ts.type)
2385 {
2386 case BT_INTEGER:
2387 /* Integer case is easy, we've got a builtin op. */
2388 type = TREE_TYPE (args[0]);
2389
2390 if (modulo)
2391 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2392 args[0], args[1]);
2393 else
2394 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2395 args[0], args[1]);
2396 break;
2397
2398 case BT_REAL:
2399 fmod = NULL_TREE;
2400 /* Check if we have a builtin fmod. */
2401 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
2402
2403 /* The builtin should always be available. */
2404 gcc_assert (fmod != NULL_TREE);
2405
2406 tmp = build_addr (fmod);
2407 se->expr = build_call_array_loc (input_location,
2408 TREE_TYPE (TREE_TYPE (fmod)),
2409 tmp, 2, args);
2410 if (modulo == 0)
2411 return;
2412
2413 type = TREE_TYPE (args[0]);
2414
2415 args[0] = gfc_evaluate_now (args[0], &se->pre);
2416 args[1] = gfc_evaluate_now (args[1], &se->pre);
2417
2418 /* Definition:
2419 modulo = arg - floor (arg/arg2) * arg2
2420
2421 In order to calculate the result accurately, we use the fmod
2422 function as follows.
2423
2424 res = fmod (arg, arg2);
2425 if (res)
2426 {
2427 if ((arg < 0) xor (arg2 < 0))
2428 res += arg2;
2429 }
2430 else
2431 res = copysign (0., arg2);
2432
2433 => As two nested ternary exprs:
2434
2435 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2436 : copysign (0., arg2);
2437
2438 */
2439
2440 zero = gfc_build_const (type, integer_zero_node);
2441 tmp = gfc_evaluate_now (se->expr, &se->pre);
2442 if (!flag_signed_zeros)
2443 {
2444 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2445 args[0], zero);
2446 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2447 args[1], zero);
2448 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2449 boolean_type_node, test, test2);
2450 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2451 tmp, zero);
2452 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2453 boolean_type_node, test, test2);
2454 test = gfc_evaluate_now (test, &se->pre);
2455 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2456 fold_build2_loc (input_location,
2457 PLUS_EXPR,
2458 type, tmp, args[1]),
2459 tmp);
2460 }
2461 else
2462 {
2463 tree expr1, copysign, cscall;
2464 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
2465 expr->ts.kind);
2466 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2467 args[0], zero);
2468 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2469 args[1], zero);
2470 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2471 boolean_type_node, test, test2);
2472 expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
2473 fold_build2_loc (input_location,
2474 PLUS_EXPR,
2475 type, tmp, args[1]),
2476 tmp);
2477 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2478 tmp, zero);
2479 cscall = build_call_expr_loc (input_location, copysign, 2, zero,
2480 args[1]);
2481 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2482 expr1, cscall);
2483 }
2484 return;
2485
2486 default:
2487 gcc_unreachable ();
2488 }
2489 }
2490
2491 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2492 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2493 where the right shifts are logical (i.e. 0's are shifted in).
2494 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2495 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2496 DSHIFTL(I,J,0) = I
2497 DSHIFTL(I,J,BITSIZE) = J
2498 DSHIFTR(I,J,0) = J
2499 DSHIFTR(I,J,BITSIZE) = I. */
2500
2501 static void
gfc_conv_intrinsic_dshift(gfc_se * se,gfc_expr * expr,bool dshiftl)2502 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
2503 {
2504 tree type, utype, stype, arg1, arg2, shift, res, left, right;
2505 tree args[3], cond, tmp;
2506 int bitsize;
2507
2508 gfc_conv_intrinsic_function_args (se, expr, args, 3);
2509
2510 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
2511 type = TREE_TYPE (args[0]);
2512 bitsize = TYPE_PRECISION (type);
2513 utype = unsigned_type_for (type);
2514 stype = TREE_TYPE (args[2]);
2515
2516 arg1 = gfc_evaluate_now (args[0], &se->pre);
2517 arg2 = gfc_evaluate_now (args[1], &se->pre);
2518 shift = gfc_evaluate_now (args[2], &se->pre);
2519
2520 /* The generic case. */
2521 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
2522 build_int_cst (stype, bitsize), shift);
2523 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
2524 arg1, dshiftl ? shift : tmp);
2525
2526 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
2527 fold_convert (utype, arg2), dshiftl ? tmp : shift);
2528 right = fold_convert (type, right);
2529
2530 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
2531
2532 /* Special cases. */
2533 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
2534 build_int_cst (stype, 0));
2535 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
2536 dshiftl ? arg1 : arg2, res);
2537
2538 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
2539 build_int_cst (stype, bitsize));
2540 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
2541 dshiftl ? arg2 : arg1, res);
2542
2543 se->expr = res;
2544 }
2545
2546
2547 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2548
2549 static void
gfc_conv_intrinsic_dim(gfc_se * se,gfc_expr * expr)2550 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
2551 {
2552 tree val;
2553 tree tmp;
2554 tree type;
2555 tree zero;
2556 tree args[2];
2557
2558 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2559 type = TREE_TYPE (args[0]);
2560
2561 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
2562 val = gfc_evaluate_now (val, &se->pre);
2563
2564 zero = gfc_build_const (type, integer_zero_node);
2565 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
2566 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
2567 }
2568
2569
2570 /* SIGN(A, B) is absolute value of A times sign of B.
2571 The real value versions use library functions to ensure the correct
2572 handling of negative zero. Integer case implemented as:
2573 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2574 */
2575
2576 static void
gfc_conv_intrinsic_sign(gfc_se * se,gfc_expr * expr)2577 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
2578 {
2579 tree tmp;
2580 tree type;
2581 tree args[2];
2582
2583 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2584 if (expr->ts.type == BT_REAL)
2585 {
2586 tree abs;
2587
2588 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
2589 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
2590
2591 /* We explicitly have to ignore the minus sign. We do so by using
2592 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2593 if (!flag_sign_zero
2594 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
2595 {
2596 tree cond, zero;
2597 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
2598 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2599 args[1], zero);
2600 se->expr = fold_build3_loc (input_location, COND_EXPR,
2601 TREE_TYPE (args[0]), cond,
2602 build_call_expr_loc (input_location, abs, 1,
2603 args[0]),
2604 build_call_expr_loc (input_location, tmp, 2,
2605 args[0], args[1]));
2606 }
2607 else
2608 se->expr = build_call_expr_loc (input_location, tmp, 2,
2609 args[0], args[1]);
2610 return;
2611 }
2612
2613 /* Having excluded floating point types, we know we are now dealing
2614 with signed integer types. */
2615 type = TREE_TYPE (args[0]);
2616
2617 /* Args[0] is used multiple times below. */
2618 args[0] = gfc_evaluate_now (args[0], &se->pre);
2619
2620 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2621 the signs of A and B are the same, and of all ones if they differ. */
2622 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
2623 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
2624 build_int_cst (type, TYPE_PRECISION (type) - 1));
2625 tmp = gfc_evaluate_now (tmp, &se->pre);
2626
2627 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2628 is all ones (i.e. -1). */
2629 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
2630 fold_build2_loc (input_location, PLUS_EXPR,
2631 type, args[0], tmp), tmp);
2632 }
2633
2634
2635 /* Test for the presence of an optional argument. */
2636
2637 static void
gfc_conv_intrinsic_present(gfc_se * se,gfc_expr * expr)2638 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
2639 {
2640 gfc_expr *arg;
2641
2642 arg = expr->value.function.actual->expr;
2643 gcc_assert (arg->expr_type == EXPR_VARIABLE);
2644 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
2645 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2646 }
2647
2648
2649 /* Calculate the double precision product of two single precision values. */
2650
2651 static void
gfc_conv_intrinsic_dprod(gfc_se * se,gfc_expr * expr)2652 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
2653 {
2654 tree type;
2655 tree args[2];
2656
2657 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2658
2659 /* Convert the args to double precision before multiplying. */
2660 type = gfc_typenode_for_spec (&expr->ts);
2661 args[0] = convert (type, args[0]);
2662 args[1] = convert (type, args[1]);
2663 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
2664 args[1]);
2665 }
2666
2667
2668 /* Return a length one character string containing an ascii character. */
2669
2670 static void
gfc_conv_intrinsic_char(gfc_se * se,gfc_expr * expr)2671 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
2672 {
2673 tree arg[2];
2674 tree var;
2675 tree type;
2676 unsigned int num_args;
2677
2678 num_args = gfc_intrinsic_argument_list_length (expr);
2679 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
2680
2681 type = gfc_get_char_type (expr->ts.kind);
2682 var = gfc_create_var (type, "char");
2683
2684 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
2685 gfc_add_modify (&se->pre, var, arg[0]);
2686 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
2687 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2688 }
2689
2690
2691 static void
gfc_conv_intrinsic_ctime(gfc_se * se,gfc_expr * expr)2692 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
2693 {
2694 tree var;
2695 tree len;
2696 tree tmp;
2697 tree cond;
2698 tree fndecl;
2699 tree *args;
2700 unsigned int num_args;
2701
2702 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2703 args = XALLOCAVEC (tree, num_args);
2704
2705 var = gfc_create_var (pchar_type_node, "pstr");
2706 len = gfc_create_var (gfc_charlen_type_node, "len");
2707
2708 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2709 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2710 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2711
2712 fndecl = build_addr (gfor_fndecl_ctime);
2713 tmp = build_call_array_loc (input_location,
2714 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
2715 fndecl, num_args, args);
2716 gfc_add_expr_to_block (&se->pre, tmp);
2717
2718 /* Free the temporary afterwards, if necessary. */
2719 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2720 len, build_int_cst (TREE_TYPE (len), 0));
2721 tmp = gfc_call_free (var);
2722 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2723 gfc_add_expr_to_block (&se->post, tmp);
2724
2725 se->expr = var;
2726 se->string_length = len;
2727 }
2728
2729
2730 static void
gfc_conv_intrinsic_fdate(gfc_se * se,gfc_expr * expr)2731 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
2732 {
2733 tree var;
2734 tree len;
2735 tree tmp;
2736 tree cond;
2737 tree fndecl;
2738 tree *args;
2739 unsigned int num_args;
2740
2741 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2742 args = XALLOCAVEC (tree, num_args);
2743
2744 var = gfc_create_var (pchar_type_node, "pstr");
2745 len = gfc_create_var (gfc_charlen_type_node, "len");
2746
2747 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2748 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2749 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2750
2751 fndecl = build_addr (gfor_fndecl_fdate);
2752 tmp = build_call_array_loc (input_location,
2753 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
2754 fndecl, num_args, args);
2755 gfc_add_expr_to_block (&se->pre, tmp);
2756
2757 /* Free the temporary afterwards, if necessary. */
2758 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2759 len, build_int_cst (TREE_TYPE (len), 0));
2760 tmp = gfc_call_free (var);
2761 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2762 gfc_add_expr_to_block (&se->post, tmp);
2763
2764 se->expr = var;
2765 se->string_length = len;
2766 }
2767
2768
2769 /* Generate a direct call to free() for the FREE subroutine. */
2770
2771 static tree
conv_intrinsic_free(gfc_code * code)2772 conv_intrinsic_free (gfc_code *code)
2773 {
2774 stmtblock_t block;
2775 gfc_se argse;
2776 tree arg, call;
2777
2778 gfc_init_se (&argse, NULL);
2779 gfc_conv_expr (&argse, code->ext.actual->expr);
2780 arg = fold_convert (ptr_type_node, argse.expr);
2781
2782 gfc_init_block (&block);
2783 call = build_call_expr_loc (input_location,
2784 builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
2785 gfc_add_expr_to_block (&block, call);
2786 return gfc_finish_block (&block);
2787 }
2788
2789
2790 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2791 conversions. */
2792
2793 static tree
conv_intrinsic_system_clock(gfc_code * code)2794 conv_intrinsic_system_clock (gfc_code *code)
2795 {
2796 stmtblock_t block;
2797 gfc_se count_se, count_rate_se, count_max_se;
2798 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
2799 tree tmp;
2800 int least;
2801
2802 gfc_expr *count = code->ext.actual->expr;
2803 gfc_expr *count_rate = code->ext.actual->next->expr;
2804 gfc_expr *count_max = code->ext.actual->next->next->expr;
2805
2806 /* Evaluate our arguments. */
2807 if (count)
2808 {
2809 gfc_init_se (&count_se, NULL);
2810 gfc_conv_expr (&count_se, count);
2811 }
2812
2813 if (count_rate)
2814 {
2815 gfc_init_se (&count_rate_se, NULL);
2816 gfc_conv_expr (&count_rate_se, count_rate);
2817 }
2818
2819 if (count_max)
2820 {
2821 gfc_init_se (&count_max_se, NULL);
2822 gfc_conv_expr (&count_max_se, count_max);
2823 }
2824
2825 /* Find the smallest kind found of the arguments. */
2826 least = 16;
2827 least = (count && count->ts.kind < least) ? count->ts.kind : least;
2828 least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
2829 : least;
2830 least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
2831 : least;
2832
2833 /* Prepare temporary variables. */
2834
2835 if (count)
2836 {
2837 if (least >= 8)
2838 arg1 = gfc_create_var (gfc_get_int_type (8), "count");
2839 else if (least == 4)
2840 arg1 = gfc_create_var (gfc_get_int_type (4), "count");
2841 else if (count->ts.kind == 1)
2842 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
2843 count->ts.kind);
2844 else
2845 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
2846 count->ts.kind);
2847 }
2848
2849 if (count_rate)
2850 {
2851 if (least >= 8)
2852 arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
2853 else if (least == 4)
2854 arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
2855 else
2856 arg2 = integer_zero_node;
2857 }
2858
2859 if (count_max)
2860 {
2861 if (least >= 8)
2862 arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
2863 else if (least == 4)
2864 arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
2865 else
2866 arg3 = integer_zero_node;
2867 }
2868
2869 /* Make the function call. */
2870 gfc_init_block (&block);
2871
2872 if (least <= 2)
2873 {
2874 if (least == 1)
2875 {
2876 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
2877 : null_pointer_node;
2878 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
2879 : null_pointer_node;
2880 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
2881 : null_pointer_node;
2882 }
2883
2884 if (least == 2)
2885 {
2886 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
2887 : null_pointer_node;
2888 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
2889 : null_pointer_node;
2890 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
2891 : null_pointer_node;
2892 }
2893 }
2894 else
2895 {
2896 if (least == 4)
2897 {
2898 tmp = build_call_expr_loc (input_location,
2899 gfor_fndecl_system_clock4, 3,
2900 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
2901 : null_pointer_node,
2902 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
2903 : null_pointer_node,
2904 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
2905 : null_pointer_node);
2906 gfc_add_expr_to_block (&block, tmp);
2907 }
2908 /* Handle kind>=8, 10, or 16 arguments */
2909 if (least >= 8)
2910 {
2911 tmp = build_call_expr_loc (input_location,
2912 gfor_fndecl_system_clock8, 3,
2913 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
2914 : null_pointer_node,
2915 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
2916 : null_pointer_node,
2917 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
2918 : null_pointer_node);
2919 gfc_add_expr_to_block (&block, tmp);
2920 }
2921 }
2922
2923 /* And store values back if needed. */
2924 if (arg1 && arg1 != count_se.expr)
2925 gfc_add_modify (&block, count_se.expr,
2926 fold_convert (TREE_TYPE (count_se.expr), arg1));
2927 if (arg2 && arg2 != count_rate_se.expr)
2928 gfc_add_modify (&block, count_rate_se.expr,
2929 fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
2930 if (arg3 && arg3 != count_max_se.expr)
2931 gfc_add_modify (&block, count_max_se.expr,
2932 fold_convert (TREE_TYPE (count_max_se.expr), arg3));
2933
2934 return gfc_finish_block (&block);
2935 }
2936
2937
2938 /* Return a character string containing the tty name. */
2939
2940 static void
gfc_conv_intrinsic_ttynam(gfc_se * se,gfc_expr * expr)2941 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
2942 {
2943 tree var;
2944 tree len;
2945 tree tmp;
2946 tree cond;
2947 tree fndecl;
2948 tree *args;
2949 unsigned int num_args;
2950
2951 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2952 args = XALLOCAVEC (tree, num_args);
2953
2954 var = gfc_create_var (pchar_type_node, "pstr");
2955 len = gfc_create_var (gfc_charlen_type_node, "len");
2956
2957 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2958 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2959 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2960
2961 fndecl = build_addr (gfor_fndecl_ttynam);
2962 tmp = build_call_array_loc (input_location,
2963 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
2964 fndecl, num_args, args);
2965 gfc_add_expr_to_block (&se->pre, tmp);
2966
2967 /* Free the temporary afterwards, if necessary. */
2968 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2969 len, build_int_cst (TREE_TYPE (len), 0));
2970 tmp = gfc_call_free (var);
2971 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2972 gfc_add_expr_to_block (&se->post, tmp);
2973
2974 se->expr = var;
2975 se->string_length = len;
2976 }
2977
2978
2979 /* Get the minimum/maximum value of all the parameters.
2980 minmax (a1, a2, a3, ...)
2981 {
2982 mvar = a1;
2983 if (a2 .op. mvar || isnan (mvar))
2984 mvar = a2;
2985 if (a3 .op. mvar || isnan (mvar))
2986 mvar = a3;
2987 ...
2988 return mvar
2989 }
2990 */
2991
2992 /* TODO: Mismatching types can occur when specific names are used.
2993 These should be handled during resolution. */
2994 static void
gfc_conv_intrinsic_minmax(gfc_se * se,gfc_expr * expr,enum tree_code op)2995 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
2996 {
2997 tree tmp;
2998 tree mvar;
2999 tree val;
3000 tree thencase;
3001 tree *args;
3002 tree type;
3003 gfc_actual_arglist *argexpr;
3004 unsigned int i, nargs;
3005
3006 nargs = gfc_intrinsic_argument_list_length (expr);
3007 args = XALLOCAVEC (tree, nargs);
3008
3009 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3010 type = gfc_typenode_for_spec (&expr->ts);
3011
3012 argexpr = expr->value.function.actual;
3013 if (TREE_TYPE (args[0]) != type)
3014 args[0] = convert (type, args[0]);
3015 /* Only evaluate the argument once. */
3016 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
3017 args[0] = gfc_evaluate_now (args[0], &se->pre);
3018
3019 mvar = gfc_create_var (type, "M");
3020 gfc_add_modify (&se->pre, mvar, args[0]);
3021 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
3022 {
3023 tree cond, isnan;
3024
3025 val = args[i];
3026
3027 /* Handle absent optional arguments by ignoring the comparison. */
3028 if (argexpr->expr->expr_type == EXPR_VARIABLE
3029 && argexpr->expr->symtree->n.sym->attr.optional
3030 && TREE_CODE (val) == INDIRECT_REF)
3031 cond = fold_build2_loc (input_location,
3032 NE_EXPR, boolean_type_node,
3033 TREE_OPERAND (val, 0),
3034 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3035 else
3036 {
3037 cond = NULL_TREE;
3038
3039 /* Only evaluate the argument once. */
3040 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
3041 val = gfc_evaluate_now (val, &se->pre);
3042 }
3043
3044 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
3045
3046 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3047 convert (type, val), mvar);
3048
3049 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3050 __builtin_isnan might be made dependent on that module being loaded,
3051 to help performance of programs that don't rely on IEEE semantics. */
3052 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
3053 {
3054 isnan = build_call_expr_loc (input_location,
3055 builtin_decl_explicit (BUILT_IN_ISNAN),
3056 1, mvar);
3057 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3058 boolean_type_node, tmp,
3059 fold_convert (boolean_type_node, isnan));
3060 }
3061 tmp = build3_v (COND_EXPR, tmp, thencase,
3062 build_empty_stmt (input_location));
3063
3064 if (cond != NULL_TREE)
3065 tmp = build3_v (COND_EXPR, cond, tmp,
3066 build_empty_stmt (input_location));
3067
3068 gfc_add_expr_to_block (&se->pre, tmp);
3069 argexpr = argexpr->next;
3070 }
3071 se->expr = mvar;
3072 }
3073
3074
3075 /* Generate library calls for MIN and MAX intrinsics for character
3076 variables. */
3077 static void
gfc_conv_intrinsic_minmax_char(gfc_se * se,gfc_expr * expr,int op)3078 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3079 {
3080 tree *args;
3081 tree var, len, fndecl, tmp, cond, function;
3082 unsigned int nargs;
3083
3084 nargs = gfc_intrinsic_argument_list_length (expr);
3085 args = XALLOCAVEC (tree, nargs + 4);
3086 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3087
3088 /* Create the result variables. */
3089 len = gfc_create_var (gfc_charlen_type_node, "len");
3090 args[0] = gfc_build_addr_expr (NULL_TREE, len);
3091 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3092 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3093 args[2] = build_int_cst (integer_type_node, op);
3094 args[3] = build_int_cst (integer_type_node, nargs / 2);
3095
3096 if (expr->ts.kind == 1)
3097 function = gfor_fndecl_string_minmax;
3098 else if (expr->ts.kind == 4)
3099 function = gfor_fndecl_string_minmax_char4;
3100 else
3101 gcc_unreachable ();
3102
3103 /* Make the function call. */
3104 fndecl = build_addr (function);
3105 tmp = build_call_array_loc (input_location,
3106 TREE_TYPE (TREE_TYPE (function)), fndecl,
3107 nargs + 4, args);
3108 gfc_add_expr_to_block (&se->pre, tmp);
3109
3110 /* Free the temporary afterwards, if necessary. */
3111 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3112 len, build_int_cst (TREE_TYPE (len), 0));
3113 tmp = gfc_call_free (var);
3114 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3115 gfc_add_expr_to_block (&se->post, tmp);
3116
3117 se->expr = var;
3118 se->string_length = len;
3119 }
3120
3121
3122 /* Create a symbol node for this intrinsic. The symbol from the frontend
3123 has the generic name. */
3124
3125 static gfc_symbol *
gfc_get_symbol_for_expr(gfc_expr * expr,bool ignore_optional)3126 gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3127 {
3128 gfc_symbol *sym;
3129
3130 /* TODO: Add symbols for intrinsic function to the global namespace. */
3131 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3132 sym = gfc_new_symbol (expr->value.function.name, NULL);
3133
3134 sym->ts = expr->ts;
3135 sym->attr.external = 1;
3136 sym->attr.function = 1;
3137 sym->attr.always_explicit = 1;
3138 sym->attr.proc = PROC_INTRINSIC;
3139 sym->attr.flavor = FL_PROCEDURE;
3140 sym->result = sym;
3141 if (expr->rank > 0)
3142 {
3143 sym->attr.dimension = 1;
3144 sym->as = gfc_get_array_spec ();
3145 sym->as->type = AS_ASSUMED_SHAPE;
3146 sym->as->rank = expr->rank;
3147 }
3148
3149 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3150 ignore_optional ? expr->value.function.actual
3151 : NULL);
3152
3153 return sym;
3154 }
3155
3156 /* Generate a call to an external intrinsic function. */
3157 static void
gfc_conv_intrinsic_funcall(gfc_se * se,gfc_expr * expr)3158 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3159 {
3160 gfc_symbol *sym;
3161 vec<tree, va_gc> *append_args;
3162
3163 gcc_assert (!se->ss || se->ss->info->expr == expr);
3164
3165 if (se->ss)
3166 gcc_assert (expr->rank > 0);
3167 else
3168 gcc_assert (expr->rank == 0);
3169
3170 sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3171
3172 /* Calls to libgfortran_matmul need to be appended special arguments,
3173 to be able to call the BLAS ?gemm functions if required and possible. */
3174 append_args = NULL;
3175 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3176 && sym->ts.type != BT_LOGICAL)
3177 {
3178 tree cint = gfc_get_int_type (gfc_c_int_kind);
3179
3180 if (flag_external_blas
3181 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3182 && (sym->ts.kind == 4 || sym->ts.kind == 8))
3183 {
3184 tree gemm_fndecl;
3185
3186 if (sym->ts.type == BT_REAL)
3187 {
3188 if (sym->ts.kind == 4)
3189 gemm_fndecl = gfor_fndecl_sgemm;
3190 else
3191 gemm_fndecl = gfor_fndecl_dgemm;
3192 }
3193 else
3194 {
3195 if (sym->ts.kind == 4)
3196 gemm_fndecl = gfor_fndecl_cgemm;
3197 else
3198 gemm_fndecl = gfor_fndecl_zgemm;
3199 }
3200
3201 vec_alloc (append_args, 3);
3202 append_args->quick_push (build_int_cst (cint, 1));
3203 append_args->quick_push (build_int_cst (cint,
3204 flag_blas_matmul_limit));
3205 append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3206 gemm_fndecl));
3207 }
3208 else
3209 {
3210 vec_alloc (append_args, 3);
3211 append_args->quick_push (build_int_cst (cint, 0));
3212 append_args->quick_push (build_int_cst (cint, 0));
3213 append_args->quick_push (null_pointer_node);
3214 }
3215 }
3216
3217 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3218 append_args);
3219 gfc_free_symbol (sym);
3220 }
3221
3222 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3223 Implemented as
3224 any(a)
3225 {
3226 forall (i=...)
3227 if (a[i] != 0)
3228 return 1
3229 end forall
3230 return 0
3231 }
3232 all(a)
3233 {
3234 forall (i=...)
3235 if (a[i] == 0)
3236 return 0
3237 end forall
3238 return 1
3239 }
3240 */
3241 static void
gfc_conv_intrinsic_anyall(gfc_se * se,gfc_expr * expr,enum tree_code op)3242 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
3243 {
3244 tree resvar;
3245 stmtblock_t block;
3246 stmtblock_t body;
3247 tree type;
3248 tree tmp;
3249 tree found;
3250 gfc_loopinfo loop;
3251 gfc_actual_arglist *actual;
3252 gfc_ss *arrayss;
3253 gfc_se arrayse;
3254 tree exit_label;
3255
3256 if (se->ss)
3257 {
3258 gfc_conv_intrinsic_funcall (se, expr);
3259 return;
3260 }
3261
3262 actual = expr->value.function.actual;
3263 type = gfc_typenode_for_spec (&expr->ts);
3264 /* Initialize the result. */
3265 resvar = gfc_create_var (type, "test");
3266 if (op == EQ_EXPR)
3267 tmp = convert (type, boolean_true_node);
3268 else
3269 tmp = convert (type, boolean_false_node);
3270 gfc_add_modify (&se->pre, resvar, tmp);
3271
3272 /* Walk the arguments. */
3273 arrayss = gfc_walk_expr (actual->expr);
3274 gcc_assert (arrayss != gfc_ss_terminator);
3275
3276 /* Initialize the scalarizer. */
3277 gfc_init_loopinfo (&loop);
3278 exit_label = gfc_build_label_decl (NULL_TREE);
3279 TREE_USED (exit_label) = 1;
3280 gfc_add_ss_to_loop (&loop, arrayss);
3281
3282 /* Initialize the loop. */
3283 gfc_conv_ss_startstride (&loop);
3284 gfc_conv_loop_setup (&loop, &expr->where);
3285
3286 gfc_mark_ss_chain_used (arrayss, 1);
3287 /* Generate the loop body. */
3288 gfc_start_scalarized_body (&loop, &body);
3289
3290 /* If the condition matches then set the return value. */
3291 gfc_start_block (&block);
3292 if (op == EQ_EXPR)
3293 tmp = convert (type, boolean_false_node);
3294 else
3295 tmp = convert (type, boolean_true_node);
3296 gfc_add_modify (&block, resvar, tmp);
3297
3298 /* And break out of the loop. */
3299 tmp = build1_v (GOTO_EXPR, exit_label);
3300 gfc_add_expr_to_block (&block, tmp);
3301
3302 found = gfc_finish_block (&block);
3303
3304 /* Check this element. */
3305 gfc_init_se (&arrayse, NULL);
3306 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3307 arrayse.ss = arrayss;
3308 gfc_conv_expr_val (&arrayse, actual->expr);
3309
3310 gfc_add_block_to_block (&body, &arrayse.pre);
3311 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
3312 build_int_cst (TREE_TYPE (arrayse.expr), 0));
3313 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
3314 gfc_add_expr_to_block (&body, tmp);
3315 gfc_add_block_to_block (&body, &arrayse.post);
3316
3317 gfc_trans_scalarizing_loops (&loop, &body);
3318
3319 /* Add the exit label. */
3320 tmp = build1_v (LABEL_EXPR, exit_label);
3321 gfc_add_expr_to_block (&loop.pre, tmp);
3322
3323 gfc_add_block_to_block (&se->pre, &loop.pre);
3324 gfc_add_block_to_block (&se->pre, &loop.post);
3325 gfc_cleanup_loop (&loop);
3326
3327 se->expr = resvar;
3328 }
3329
3330 /* COUNT(A) = Number of true elements in A. */
3331 static void
gfc_conv_intrinsic_count(gfc_se * se,gfc_expr * expr)3332 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
3333 {
3334 tree resvar;
3335 tree type;
3336 stmtblock_t body;
3337 tree tmp;
3338 gfc_loopinfo loop;
3339 gfc_actual_arglist *actual;
3340 gfc_ss *arrayss;
3341 gfc_se arrayse;
3342
3343 if (se->ss)
3344 {
3345 gfc_conv_intrinsic_funcall (se, expr);
3346 return;
3347 }
3348
3349 actual = expr->value.function.actual;
3350
3351 type = gfc_typenode_for_spec (&expr->ts);
3352 /* Initialize the result. */
3353 resvar = gfc_create_var (type, "count");
3354 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
3355
3356 /* Walk the arguments. */
3357 arrayss = gfc_walk_expr (actual->expr);
3358 gcc_assert (arrayss != gfc_ss_terminator);
3359
3360 /* Initialize the scalarizer. */
3361 gfc_init_loopinfo (&loop);
3362 gfc_add_ss_to_loop (&loop, arrayss);
3363
3364 /* Initialize the loop. */
3365 gfc_conv_ss_startstride (&loop);
3366 gfc_conv_loop_setup (&loop, &expr->where);
3367
3368 gfc_mark_ss_chain_used (arrayss, 1);
3369 /* Generate the loop body. */
3370 gfc_start_scalarized_body (&loop, &body);
3371
3372 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
3373 resvar, build_int_cst (TREE_TYPE (resvar), 1));
3374 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
3375
3376 gfc_init_se (&arrayse, NULL);
3377 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3378 arrayse.ss = arrayss;
3379 gfc_conv_expr_val (&arrayse, actual->expr);
3380 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
3381 build_empty_stmt (input_location));
3382
3383 gfc_add_block_to_block (&body, &arrayse.pre);
3384 gfc_add_expr_to_block (&body, tmp);
3385 gfc_add_block_to_block (&body, &arrayse.post);
3386
3387 gfc_trans_scalarizing_loops (&loop, &body);
3388
3389 gfc_add_block_to_block (&se->pre, &loop.pre);
3390 gfc_add_block_to_block (&se->pre, &loop.post);
3391 gfc_cleanup_loop (&loop);
3392
3393 se->expr = resvar;
3394 }
3395
3396
3397 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3398 struct and return the corresponding loopinfo. */
3399
3400 static gfc_loopinfo *
enter_nested_loop(gfc_se * se)3401 enter_nested_loop (gfc_se *se)
3402 {
3403 se->ss = se->ss->nested_ss;
3404 gcc_assert (se->ss == se->ss->loop->ss);
3405
3406 return se->ss->loop;
3407 }
3408
3409
3410 /* Inline implementation of the sum and product intrinsics. */
3411 static void
gfc_conv_intrinsic_arith(gfc_se * se,gfc_expr * expr,enum tree_code op,bool norm2)3412 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
3413 bool norm2)
3414 {
3415 tree resvar;
3416 tree scale = NULL_TREE;
3417 tree type;
3418 stmtblock_t body;
3419 stmtblock_t block;
3420 tree tmp;
3421 gfc_loopinfo loop, *ploop;
3422 gfc_actual_arglist *arg_array, *arg_mask;
3423 gfc_ss *arrayss = NULL;
3424 gfc_ss *maskss = NULL;
3425 gfc_se arrayse;
3426 gfc_se maskse;
3427 gfc_se *parent_se;
3428 gfc_expr *arrayexpr;
3429 gfc_expr *maskexpr;
3430
3431 if (expr->rank > 0)
3432 {
3433 gcc_assert (gfc_inline_intrinsic_function_p (expr));
3434 parent_se = se;
3435 }
3436 else
3437 parent_se = NULL;
3438
3439 type = gfc_typenode_for_spec (&expr->ts);
3440 /* Initialize the result. */
3441 resvar = gfc_create_var (type, "val");
3442 if (norm2)
3443 {
3444 /* result = 0.0;
3445 scale = 1.0. */
3446 scale = gfc_create_var (type, "scale");
3447 gfc_add_modify (&se->pre, scale,
3448 gfc_build_const (type, integer_one_node));
3449 tmp = gfc_build_const (type, integer_zero_node);
3450 }
3451 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
3452 tmp = gfc_build_const (type, integer_zero_node);
3453 else if (op == NE_EXPR)
3454 /* PARITY. */
3455 tmp = convert (type, boolean_false_node);
3456 else if (op == BIT_AND_EXPR)
3457 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
3458 type, integer_one_node));
3459 else
3460 tmp = gfc_build_const (type, integer_one_node);
3461
3462 gfc_add_modify (&se->pre, resvar, tmp);
3463
3464 arg_array = expr->value.function.actual;
3465
3466 arrayexpr = arg_array->expr;
3467
3468 if (op == NE_EXPR || norm2)
3469 /* PARITY and NORM2. */
3470 maskexpr = NULL;
3471 else
3472 {
3473 arg_mask = arg_array->next->next;
3474 gcc_assert (arg_mask != NULL);
3475 maskexpr = arg_mask->expr;
3476 }
3477
3478 if (expr->rank == 0)
3479 {
3480 /* Walk the arguments. */
3481 arrayss = gfc_walk_expr (arrayexpr);
3482 gcc_assert (arrayss != gfc_ss_terminator);
3483
3484 if (maskexpr && maskexpr->rank > 0)
3485 {
3486 maskss = gfc_walk_expr (maskexpr);
3487 gcc_assert (maskss != gfc_ss_terminator);
3488 }
3489 else
3490 maskss = NULL;
3491
3492 /* Initialize the scalarizer. */
3493 gfc_init_loopinfo (&loop);
3494 gfc_add_ss_to_loop (&loop, arrayss);
3495 if (maskexpr && maskexpr->rank > 0)
3496 gfc_add_ss_to_loop (&loop, maskss);
3497
3498 /* Initialize the loop. */
3499 gfc_conv_ss_startstride (&loop);
3500 gfc_conv_loop_setup (&loop, &expr->where);
3501
3502 gfc_mark_ss_chain_used (arrayss, 1);
3503 if (maskexpr && maskexpr->rank > 0)
3504 gfc_mark_ss_chain_used (maskss, 1);
3505
3506 ploop = &loop;
3507 }
3508 else
3509 /* All the work has been done in the parent loops. */
3510 ploop = enter_nested_loop (se);
3511
3512 gcc_assert (ploop);
3513
3514 /* Generate the loop body. */
3515 gfc_start_scalarized_body (ploop, &body);
3516
3517 /* If we have a mask, only add this element if the mask is set. */
3518 if (maskexpr && maskexpr->rank > 0)
3519 {
3520 gfc_init_se (&maskse, parent_se);
3521 gfc_copy_loopinfo_to_se (&maskse, ploop);
3522 if (expr->rank == 0)
3523 maskse.ss = maskss;
3524 gfc_conv_expr_val (&maskse, maskexpr);
3525 gfc_add_block_to_block (&body, &maskse.pre);
3526
3527 gfc_start_block (&block);
3528 }
3529 else
3530 gfc_init_block (&block);
3531
3532 /* Do the actual summation/product. */
3533 gfc_init_se (&arrayse, parent_se);
3534 gfc_copy_loopinfo_to_se (&arrayse, ploop);
3535 if (expr->rank == 0)
3536 arrayse.ss = arrayss;
3537 gfc_conv_expr_val (&arrayse, arrayexpr);
3538 gfc_add_block_to_block (&block, &arrayse.pre);
3539
3540 if (norm2)
3541 {
3542 /* if (x (i) != 0.0)
3543 {
3544 absX = abs(x(i))
3545 if (absX > scale)
3546 {
3547 val = scale/absX;
3548 result = 1.0 + result * val * val;
3549 scale = absX;
3550 }
3551 else
3552 {
3553 val = absX/scale;
3554 result += val * val;
3555 }
3556 } */
3557 tree res1, res2, cond, absX, val;
3558 stmtblock_t ifblock1, ifblock2, ifblock3;
3559
3560 gfc_init_block (&ifblock1);
3561
3562 absX = gfc_create_var (type, "absX");
3563 gfc_add_modify (&ifblock1, absX,
3564 fold_build1_loc (input_location, ABS_EXPR, type,
3565 arrayse.expr));
3566 val = gfc_create_var (type, "val");
3567 gfc_add_expr_to_block (&ifblock1, val);
3568
3569 gfc_init_block (&ifblock2);
3570 gfc_add_modify (&ifblock2, val,
3571 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
3572 absX));
3573 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
3574 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
3575 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
3576 gfc_build_const (type, integer_one_node));
3577 gfc_add_modify (&ifblock2, resvar, res1);
3578 gfc_add_modify (&ifblock2, scale, absX);
3579 res1 = gfc_finish_block (&ifblock2);
3580
3581 gfc_init_block (&ifblock3);
3582 gfc_add_modify (&ifblock3, val,
3583 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
3584 scale));
3585 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
3586 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
3587 gfc_add_modify (&ifblock3, resvar, res2);
3588 res2 = gfc_finish_block (&ifblock3);
3589
3590 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3591 absX, scale);
3592 tmp = build3_v (COND_EXPR, cond, res1, res2);
3593 gfc_add_expr_to_block (&ifblock1, tmp);
3594 tmp = gfc_finish_block (&ifblock1);
3595
3596 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3597 arrayse.expr,
3598 gfc_build_const (type, integer_zero_node));
3599
3600 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3601 gfc_add_expr_to_block (&block, tmp);
3602 }
3603 else
3604 {
3605 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
3606 gfc_add_modify (&block, resvar, tmp);
3607 }
3608
3609 gfc_add_block_to_block (&block, &arrayse.post);
3610
3611 if (maskexpr && maskexpr->rank > 0)
3612 {
3613 /* We enclose the above in if (mask) {...} . */
3614
3615 tmp = gfc_finish_block (&block);
3616 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3617 build_empty_stmt (input_location));
3618 }
3619 else
3620 tmp = gfc_finish_block (&block);
3621 gfc_add_expr_to_block (&body, tmp);
3622
3623 gfc_trans_scalarizing_loops (ploop, &body);
3624
3625 /* For a scalar mask, enclose the loop in an if statement. */
3626 if (maskexpr && maskexpr->rank == 0)
3627 {
3628 gfc_init_block (&block);
3629 gfc_add_block_to_block (&block, &ploop->pre);
3630 gfc_add_block_to_block (&block, &ploop->post);
3631 tmp = gfc_finish_block (&block);
3632
3633 if (expr->rank > 0)
3634 {
3635 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
3636 build_empty_stmt (input_location));
3637 gfc_advance_se_ss_chain (se);
3638 }
3639 else
3640 {
3641 gcc_assert (expr->rank == 0);
3642 gfc_init_se (&maskse, NULL);
3643 gfc_conv_expr_val (&maskse, maskexpr);
3644 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3645 build_empty_stmt (input_location));
3646 }
3647
3648 gfc_add_expr_to_block (&block, tmp);
3649 gfc_add_block_to_block (&se->pre, &block);
3650 gcc_assert (se->post.head == NULL);
3651 }
3652 else
3653 {
3654 gfc_add_block_to_block (&se->pre, &ploop->pre);
3655 gfc_add_block_to_block (&se->pre, &ploop->post);
3656 }
3657
3658 if (expr->rank == 0)
3659 gfc_cleanup_loop (ploop);
3660
3661 if (norm2)
3662 {
3663 /* result = scale * sqrt(result). */
3664 tree sqrt;
3665 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
3666 resvar = build_call_expr_loc (input_location,
3667 sqrt, 1, resvar);
3668 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
3669 }
3670
3671 se->expr = resvar;
3672 }
3673
3674
3675 /* Inline implementation of the dot_product intrinsic. This function
3676 is based on gfc_conv_intrinsic_arith (the previous function). */
3677 static void
gfc_conv_intrinsic_dot_product(gfc_se * se,gfc_expr * expr)3678 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
3679 {
3680 tree resvar;
3681 tree type;
3682 stmtblock_t body;
3683 stmtblock_t block;
3684 tree tmp;
3685 gfc_loopinfo loop;
3686 gfc_actual_arglist *actual;
3687 gfc_ss *arrayss1, *arrayss2;
3688 gfc_se arrayse1, arrayse2;
3689 gfc_expr *arrayexpr1, *arrayexpr2;
3690
3691 type = gfc_typenode_for_spec (&expr->ts);
3692
3693 /* Initialize the result. */
3694 resvar = gfc_create_var (type, "val");
3695 if (expr->ts.type == BT_LOGICAL)
3696 tmp = build_int_cst (type, 0);
3697 else
3698 tmp = gfc_build_const (type, integer_zero_node);
3699
3700 gfc_add_modify (&se->pre, resvar, tmp);
3701
3702 /* Walk argument #1. */
3703 actual = expr->value.function.actual;
3704 arrayexpr1 = actual->expr;
3705 arrayss1 = gfc_walk_expr (arrayexpr1);
3706 gcc_assert (arrayss1 != gfc_ss_terminator);
3707
3708 /* Walk argument #2. */
3709 actual = actual->next;
3710 arrayexpr2 = actual->expr;
3711 arrayss2 = gfc_walk_expr (arrayexpr2);
3712 gcc_assert (arrayss2 != gfc_ss_terminator);
3713
3714 /* Initialize the scalarizer. */
3715 gfc_init_loopinfo (&loop);
3716 gfc_add_ss_to_loop (&loop, arrayss1);
3717 gfc_add_ss_to_loop (&loop, arrayss2);
3718
3719 /* Initialize the loop. */
3720 gfc_conv_ss_startstride (&loop);
3721 gfc_conv_loop_setup (&loop, &expr->where);
3722
3723 gfc_mark_ss_chain_used (arrayss1, 1);
3724 gfc_mark_ss_chain_used (arrayss2, 1);
3725
3726 /* Generate the loop body. */
3727 gfc_start_scalarized_body (&loop, &body);
3728 gfc_init_block (&block);
3729
3730 /* Make the tree expression for [conjg(]array1[)]. */
3731 gfc_init_se (&arrayse1, NULL);
3732 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
3733 arrayse1.ss = arrayss1;
3734 gfc_conv_expr_val (&arrayse1, arrayexpr1);
3735 if (expr->ts.type == BT_COMPLEX)
3736 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
3737 arrayse1.expr);
3738 gfc_add_block_to_block (&block, &arrayse1.pre);
3739
3740 /* Make the tree expression for array2. */
3741 gfc_init_se (&arrayse2, NULL);
3742 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
3743 arrayse2.ss = arrayss2;
3744 gfc_conv_expr_val (&arrayse2, arrayexpr2);
3745 gfc_add_block_to_block (&block, &arrayse2.pre);
3746
3747 /* Do the actual product and sum. */
3748 if (expr->ts.type == BT_LOGICAL)
3749 {
3750 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
3751 arrayse1.expr, arrayse2.expr);
3752 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
3753 }
3754 else
3755 {
3756 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
3757 arrayse2.expr);
3758 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
3759 }
3760 gfc_add_modify (&block, resvar, tmp);
3761
3762 /* Finish up the loop block and the loop. */
3763 tmp = gfc_finish_block (&block);
3764 gfc_add_expr_to_block (&body, tmp);
3765
3766 gfc_trans_scalarizing_loops (&loop, &body);
3767 gfc_add_block_to_block (&se->pre, &loop.pre);
3768 gfc_add_block_to_block (&se->pre, &loop.post);
3769 gfc_cleanup_loop (&loop);
3770
3771 se->expr = resvar;
3772 }
3773
3774
3775 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3776 we need to handle. For performance reasons we sometimes create two
3777 loops instead of one, where the second one is much simpler.
3778 Examples for minloc intrinsic:
3779 1) Result is an array, a call is generated
3780 2) Array mask is used and NaNs need to be supported:
3781 limit = Infinity;
3782 pos = 0;
3783 S = from;
3784 while (S <= to) {
3785 if (mask[S]) {
3786 if (pos == 0) pos = S + (1 - from);
3787 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3788 }
3789 S++;
3790 }
3791 goto lab2;
3792 lab1:;
3793 while (S <= to) {
3794 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3795 S++;
3796 }
3797 lab2:;
3798 3) NaNs need to be supported, but it is known at compile time or cheaply
3799 at runtime whether array is nonempty or not:
3800 limit = Infinity;
3801 pos = 0;
3802 S = from;
3803 while (S <= to) {
3804 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3805 S++;
3806 }
3807 if (from <= to) pos = 1;
3808 goto lab2;
3809 lab1:;
3810 while (S <= to) {
3811 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3812 S++;
3813 }
3814 lab2:;
3815 4) NaNs aren't supported, array mask is used:
3816 limit = infinities_supported ? Infinity : huge (limit);
3817 pos = 0;
3818 S = from;
3819 while (S <= to) {
3820 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3821 S++;
3822 }
3823 goto lab2;
3824 lab1:;
3825 while (S <= to) {
3826 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3827 S++;
3828 }
3829 lab2:;
3830 5) Same without array mask:
3831 limit = infinities_supported ? Infinity : huge (limit);
3832 pos = (from <= to) ? 1 : 0;
3833 S = from;
3834 while (S <= to) {
3835 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3836 S++;
3837 }
3838 For 3) and 5), if mask is scalar, this all goes into a conditional,
3839 setting pos = 0; in the else branch. */
3840
3841 static void
gfc_conv_intrinsic_minmaxloc(gfc_se * se,gfc_expr * expr,enum tree_code op)3842 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
3843 {
3844 stmtblock_t body;
3845 stmtblock_t block;
3846 stmtblock_t ifblock;
3847 stmtblock_t elseblock;
3848 tree limit;
3849 tree type;
3850 tree tmp;
3851 tree cond;
3852 tree elsetmp;
3853 tree ifbody;
3854 tree offset;
3855 tree nonempty;
3856 tree lab1, lab2;
3857 gfc_loopinfo loop;
3858 gfc_actual_arglist *actual;
3859 gfc_ss *arrayss;
3860 gfc_ss *maskss;
3861 gfc_se arrayse;
3862 gfc_se maskse;
3863 gfc_expr *arrayexpr;
3864 gfc_expr *maskexpr;
3865 tree pos;
3866 int n;
3867
3868 if (se->ss)
3869 {
3870 gfc_conv_intrinsic_funcall (se, expr);
3871 return;
3872 }
3873
3874 /* Initialize the result. */
3875 pos = gfc_create_var (gfc_array_index_type, "pos");
3876 offset = gfc_create_var (gfc_array_index_type, "offset");
3877 type = gfc_typenode_for_spec (&expr->ts);
3878
3879 /* Walk the arguments. */
3880 actual = expr->value.function.actual;
3881 arrayexpr = actual->expr;
3882 arrayss = gfc_walk_expr (arrayexpr);
3883 gcc_assert (arrayss != gfc_ss_terminator);
3884
3885 actual = actual->next->next;
3886 gcc_assert (actual);
3887 maskexpr = actual->expr;
3888 nonempty = NULL;
3889 if (maskexpr && maskexpr->rank != 0)
3890 {
3891 maskss = gfc_walk_expr (maskexpr);
3892 gcc_assert (maskss != gfc_ss_terminator);
3893 }
3894 else
3895 {
3896 mpz_t asize;
3897 if (gfc_array_size (arrayexpr, &asize))
3898 {
3899 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3900 mpz_clear (asize);
3901 nonempty = fold_build2_loc (input_location, GT_EXPR,
3902 boolean_type_node, nonempty,
3903 gfc_index_zero_node);
3904 }
3905 maskss = NULL;
3906 }
3907
3908 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
3909 switch (arrayexpr->ts.type)
3910 {
3911 case BT_REAL:
3912 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
3913 break;
3914
3915 case BT_INTEGER:
3916 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
3917 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
3918 arrayexpr->ts.kind);
3919 break;
3920
3921 default:
3922 gcc_unreachable ();
3923 }
3924
3925 /* We start with the most negative possible value for MAXLOC, and the most
3926 positive possible value for MINLOC. The most negative possible value is
3927 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3928 possible value is HUGE in both cases. */
3929 if (op == GT_EXPR)
3930 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3931 if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
3932 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
3933 build_int_cst (TREE_TYPE (tmp), 1));
3934
3935 gfc_add_modify (&se->pre, limit, tmp);
3936
3937 /* Initialize the scalarizer. */
3938 gfc_init_loopinfo (&loop);
3939 gfc_add_ss_to_loop (&loop, arrayss);
3940 if (maskss)
3941 gfc_add_ss_to_loop (&loop, maskss);
3942
3943 /* Initialize the loop. */
3944 gfc_conv_ss_startstride (&loop);
3945
3946 /* The code generated can have more than one loop in sequence (see the
3947 comment at the function header). This doesn't work well with the
3948 scalarizer, which changes arrays' offset when the scalarization loops
3949 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3950 are currently inlined in the scalar case only (for which loop is of rank
3951 one). As there is no dependency to care about in that case, there is no
3952 temporary, so that we can use the scalarizer temporary code to handle
3953 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3954 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3955 to restore offset.
3956 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3957 should eventually go away. We could either create two loops properly,
3958 or find another way to save/restore the array offsets between the two
3959 loops (without conflicting with temporary management), or use a single
3960 loop minmaxloc implementation. See PR 31067. */
3961 loop.temp_dim = loop.dimen;
3962 gfc_conv_loop_setup (&loop, &expr->where);
3963
3964 gcc_assert (loop.dimen == 1);
3965 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
3966 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3967 loop.from[0], loop.to[0]);
3968
3969 lab1 = NULL;
3970 lab2 = NULL;
3971 /* Initialize the position to zero, following Fortran 2003. We are free
3972 to do this because Fortran 95 allows the result of an entirely false
3973 mask to be processor dependent. If we know at compile time the array
3974 is non-empty and no MASK is used, we can initialize to 1 to simplify
3975 the inner loop. */
3976 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
3977 gfc_add_modify (&loop.pre, pos,
3978 fold_build3_loc (input_location, COND_EXPR,
3979 gfc_array_index_type,
3980 nonempty, gfc_index_one_node,
3981 gfc_index_zero_node));
3982 else
3983 {
3984 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
3985 lab1 = gfc_build_label_decl (NULL_TREE);
3986 TREE_USED (lab1) = 1;
3987 lab2 = gfc_build_label_decl (NULL_TREE);
3988 TREE_USED (lab2) = 1;
3989 }
3990
3991 /* An offset must be added to the loop
3992 counter to obtain the required position. */
3993 gcc_assert (loop.from[0]);
3994
3995 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3996 gfc_index_one_node, loop.from[0]);
3997 gfc_add_modify (&loop.pre, offset, tmp);
3998
3999 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
4000 if (maskss)
4001 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
4002 /* Generate the loop body. */
4003 gfc_start_scalarized_body (&loop, &body);
4004
4005 /* If we have a mask, only check this element if the mask is set. */
4006 if (maskss)
4007 {
4008 gfc_init_se (&maskse, NULL);
4009 gfc_copy_loopinfo_to_se (&maskse, &loop);
4010 maskse.ss = maskss;
4011 gfc_conv_expr_val (&maskse, maskexpr);
4012 gfc_add_block_to_block (&body, &maskse.pre);
4013
4014 gfc_start_block (&block);
4015 }
4016 else
4017 gfc_init_block (&block);
4018
4019 /* Compare with the current limit. */
4020 gfc_init_se (&arrayse, NULL);
4021 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4022 arrayse.ss = arrayss;
4023 gfc_conv_expr_val (&arrayse, arrayexpr);
4024 gfc_add_block_to_block (&block, &arrayse.pre);
4025
4026 /* We do the following if this is a more extreme value. */
4027 gfc_start_block (&ifblock);
4028
4029 /* Assign the value to the limit... */
4030 gfc_add_modify (&ifblock, limit, arrayse.expr);
4031
4032 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
4033 {
4034 stmtblock_t ifblock2;
4035 tree ifbody2;
4036
4037 gfc_start_block (&ifblock2);
4038 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4039 loop.loopvar[0], offset);
4040 gfc_add_modify (&ifblock2, pos, tmp);
4041 ifbody2 = gfc_finish_block (&ifblock2);
4042 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
4043 gfc_index_zero_node);
4044 tmp = build3_v (COND_EXPR, cond, ifbody2,
4045 build_empty_stmt (input_location));
4046 gfc_add_expr_to_block (&block, tmp);
4047 }
4048
4049 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4050 loop.loopvar[0], offset);
4051 gfc_add_modify (&ifblock, pos, tmp);
4052
4053 if (lab1)
4054 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
4055
4056 ifbody = gfc_finish_block (&ifblock);
4057
4058 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
4059 {
4060 if (lab1)
4061 cond = fold_build2_loc (input_location,
4062 op == GT_EXPR ? GE_EXPR : LE_EXPR,
4063 boolean_type_node, arrayse.expr, limit);
4064 else
4065 cond = fold_build2_loc (input_location, op, boolean_type_node,
4066 arrayse.expr, limit);
4067
4068 ifbody = build3_v (COND_EXPR, cond, ifbody,
4069 build_empty_stmt (input_location));
4070 }
4071 gfc_add_expr_to_block (&block, ifbody);
4072
4073 if (maskss)
4074 {
4075 /* We enclose the above in if (mask) {...}. */
4076 tmp = gfc_finish_block (&block);
4077
4078 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4079 build_empty_stmt (input_location));
4080 }
4081 else
4082 tmp = gfc_finish_block (&block);
4083 gfc_add_expr_to_block (&body, tmp);
4084
4085 if (lab1)
4086 {
4087 gfc_trans_scalarized_loop_boundary (&loop, &body);
4088
4089 if (HONOR_NANS (DECL_MODE (limit)))
4090 {
4091 if (nonempty != NULL)
4092 {
4093 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
4094 tmp = build3_v (COND_EXPR, nonempty, ifbody,
4095 build_empty_stmt (input_location));
4096 gfc_add_expr_to_block (&loop.code[0], tmp);
4097 }
4098 }
4099
4100 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
4101 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
4102
4103 /* If we have a mask, only check this element if the mask is set. */
4104 if (maskss)
4105 {
4106 gfc_init_se (&maskse, NULL);
4107 gfc_copy_loopinfo_to_se (&maskse, &loop);
4108 maskse.ss = maskss;
4109 gfc_conv_expr_val (&maskse, maskexpr);
4110 gfc_add_block_to_block (&body, &maskse.pre);
4111
4112 gfc_start_block (&block);
4113 }
4114 else
4115 gfc_init_block (&block);
4116
4117 /* Compare with the current limit. */
4118 gfc_init_se (&arrayse, NULL);
4119 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4120 arrayse.ss = arrayss;
4121 gfc_conv_expr_val (&arrayse, arrayexpr);
4122 gfc_add_block_to_block (&block, &arrayse.pre);
4123
4124 /* We do the following if this is a more extreme value. */
4125 gfc_start_block (&ifblock);
4126
4127 /* Assign the value to the limit... */
4128 gfc_add_modify (&ifblock, limit, arrayse.expr);
4129
4130 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4131 loop.loopvar[0], offset);
4132 gfc_add_modify (&ifblock, pos, tmp);
4133
4134 ifbody = gfc_finish_block (&ifblock);
4135
4136 cond = fold_build2_loc (input_location, op, boolean_type_node,
4137 arrayse.expr, limit);
4138
4139 tmp = build3_v (COND_EXPR, cond, ifbody,
4140 build_empty_stmt (input_location));
4141 gfc_add_expr_to_block (&block, tmp);
4142
4143 if (maskss)
4144 {
4145 /* We enclose the above in if (mask) {...}. */
4146 tmp = gfc_finish_block (&block);
4147
4148 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4149 build_empty_stmt (input_location));
4150 }
4151 else
4152 tmp = gfc_finish_block (&block);
4153 gfc_add_expr_to_block (&body, tmp);
4154 /* Avoid initializing loopvar[0] again, it should be left where
4155 it finished by the first loop. */
4156 loop.from[0] = loop.loopvar[0];
4157 }
4158
4159 gfc_trans_scalarizing_loops (&loop, &body);
4160
4161 if (lab2)
4162 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
4163
4164 /* For a scalar mask, enclose the loop in an if statement. */
4165 if (maskexpr && maskss == NULL)
4166 {
4167 gfc_init_se (&maskse, NULL);
4168 gfc_conv_expr_val (&maskse, maskexpr);
4169 gfc_init_block (&block);
4170 gfc_add_block_to_block (&block, &loop.pre);
4171 gfc_add_block_to_block (&block, &loop.post);
4172 tmp = gfc_finish_block (&block);
4173
4174 /* For the else part of the scalar mask, just initialize
4175 the pos variable the same way as above. */
4176
4177 gfc_init_block (&elseblock);
4178 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
4179 elsetmp = gfc_finish_block (&elseblock);
4180
4181 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
4182 gfc_add_expr_to_block (&block, tmp);
4183 gfc_add_block_to_block (&se->pre, &block);
4184 }
4185 else
4186 {
4187 gfc_add_block_to_block (&se->pre, &loop.pre);
4188 gfc_add_block_to_block (&se->pre, &loop.post);
4189 }
4190 gfc_cleanup_loop (&loop);
4191
4192 se->expr = convert (type, pos);
4193 }
4194
4195 /* Emit code for minval or maxval intrinsic. There are many different cases
4196 we need to handle. For performance reasons we sometimes create two
4197 loops instead of one, where the second one is much simpler.
4198 Examples for minval intrinsic:
4199 1) Result is an array, a call is generated
4200 2) Array mask is used and NaNs need to be supported, rank 1:
4201 limit = Infinity;
4202 nonempty = false;
4203 S = from;
4204 while (S <= to) {
4205 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4206 S++;
4207 }
4208 limit = nonempty ? NaN : huge (limit);
4209 lab:
4210 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4211 3) NaNs need to be supported, but it is known at compile time or cheaply
4212 at runtime whether array is nonempty or not, rank 1:
4213 limit = Infinity;
4214 S = from;
4215 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4216 limit = (from <= to) ? NaN : huge (limit);
4217 lab:
4218 while (S <= to) { limit = min (a[S], limit); S++; }
4219 4) Array mask is used and NaNs need to be supported, rank > 1:
4220 limit = Infinity;
4221 nonempty = false;
4222 fast = false;
4223 S1 = from1;
4224 while (S1 <= to1) {
4225 S2 = from2;
4226 while (S2 <= to2) {
4227 if (mask[S1][S2]) {
4228 if (fast) limit = min (a[S1][S2], limit);
4229 else {
4230 nonempty = true;
4231 if (a[S1][S2] <= limit) {
4232 limit = a[S1][S2];
4233 fast = true;
4234 }
4235 }
4236 }
4237 S2++;
4238 }
4239 S1++;
4240 }
4241 if (!fast)
4242 limit = nonempty ? NaN : huge (limit);
4243 5) NaNs need to be supported, but it is known at compile time or cheaply
4244 at runtime whether array is nonempty or not, rank > 1:
4245 limit = Infinity;
4246 fast = false;
4247 S1 = from1;
4248 while (S1 <= to1) {
4249 S2 = from2;
4250 while (S2 <= to2) {
4251 if (fast) limit = min (a[S1][S2], limit);
4252 else {
4253 if (a[S1][S2] <= limit) {
4254 limit = a[S1][S2];
4255 fast = true;
4256 }
4257 }
4258 S2++;
4259 }
4260 S1++;
4261 }
4262 if (!fast)
4263 limit = (nonempty_array) ? NaN : huge (limit);
4264 6) NaNs aren't supported, but infinities are. Array mask is used:
4265 limit = Infinity;
4266 nonempty = false;
4267 S = from;
4268 while (S <= to) {
4269 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4270 S++;
4271 }
4272 limit = nonempty ? limit : huge (limit);
4273 7) Same without array mask:
4274 limit = Infinity;
4275 S = from;
4276 while (S <= to) { limit = min (a[S], limit); S++; }
4277 limit = (from <= to) ? limit : huge (limit);
4278 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4279 limit = huge (limit);
4280 S = from;
4281 while (S <= to) { limit = min (a[S], limit); S++); }
4282 (or
4283 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4284 with array mask instead).
4285 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4286 setting limit = huge (limit); in the else branch. */
4287
4288 static void
gfc_conv_intrinsic_minmaxval(gfc_se * se,gfc_expr * expr,enum tree_code op)4289 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
4290 {
4291 tree limit;
4292 tree type;
4293 tree tmp;
4294 tree ifbody;
4295 tree nonempty;
4296 tree nonempty_var;
4297 tree lab;
4298 tree fast;
4299 tree huge_cst = NULL, nan_cst = NULL;
4300 stmtblock_t body;
4301 stmtblock_t block, block2;
4302 gfc_loopinfo loop;
4303 gfc_actual_arglist *actual;
4304 gfc_ss *arrayss;
4305 gfc_ss *maskss;
4306 gfc_se arrayse;
4307 gfc_se maskse;
4308 gfc_expr *arrayexpr;
4309 gfc_expr *maskexpr;
4310 int n;
4311
4312 if (se->ss)
4313 {
4314 gfc_conv_intrinsic_funcall (se, expr);
4315 return;
4316 }
4317
4318 type = gfc_typenode_for_spec (&expr->ts);
4319 /* Initialize the result. */
4320 limit = gfc_create_var (type, "limit");
4321 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
4322 switch (expr->ts.type)
4323 {
4324 case BT_REAL:
4325 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
4326 expr->ts.kind, 0);
4327 if (HONOR_INFINITIES (DECL_MODE (limit)))
4328 {
4329 REAL_VALUE_TYPE real;
4330 real_inf (&real);
4331 tmp = build_real (type, real);
4332 }
4333 else
4334 tmp = huge_cst;
4335 if (HONOR_NANS (DECL_MODE (limit)))
4336 nan_cst = gfc_build_nan (type, "");
4337 break;
4338
4339 case BT_INTEGER:
4340 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
4341 break;
4342
4343 default:
4344 gcc_unreachable ();
4345 }
4346
4347 /* We start with the most negative possible value for MAXVAL, and the most
4348 positive possible value for MINVAL. The most negative possible value is
4349 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4350 possible value is HUGE in both cases. */
4351 if (op == GT_EXPR)
4352 {
4353 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
4354 if (huge_cst)
4355 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
4356 TREE_TYPE (huge_cst), huge_cst);
4357 }
4358
4359 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
4360 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
4361 tmp, build_int_cst (type, 1));
4362
4363 gfc_add_modify (&se->pre, limit, tmp);
4364
4365 /* Walk the arguments. */
4366 actual = expr->value.function.actual;
4367 arrayexpr = actual->expr;
4368 arrayss = gfc_walk_expr (arrayexpr);
4369 gcc_assert (arrayss != gfc_ss_terminator);
4370
4371 actual = actual->next->next;
4372 gcc_assert (actual);
4373 maskexpr = actual->expr;
4374 nonempty = NULL;
4375 if (maskexpr && maskexpr->rank != 0)
4376 {
4377 maskss = gfc_walk_expr (maskexpr);
4378 gcc_assert (maskss != gfc_ss_terminator);
4379 }
4380 else
4381 {
4382 mpz_t asize;
4383 if (gfc_array_size (arrayexpr, &asize))
4384 {
4385 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
4386 mpz_clear (asize);
4387 nonempty = fold_build2_loc (input_location, GT_EXPR,
4388 boolean_type_node, nonempty,
4389 gfc_index_zero_node);
4390 }
4391 maskss = NULL;
4392 }
4393
4394 /* Initialize the scalarizer. */
4395 gfc_init_loopinfo (&loop);
4396 gfc_add_ss_to_loop (&loop, arrayss);
4397 if (maskss)
4398 gfc_add_ss_to_loop (&loop, maskss);
4399
4400 /* Initialize the loop. */
4401 gfc_conv_ss_startstride (&loop);
4402
4403 /* The code generated can have more than one loop in sequence (see the
4404 comment at the function header). This doesn't work well with the
4405 scalarizer, which changes arrays' offset when the scalarization loops
4406 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4407 are currently inlined in the scalar case only. As there is no dependency
4408 to care about in that case, there is no temporary, so that we can use the
4409 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4410 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4411 gfc_trans_scalarized_loop_boundary even later to restore offset.
4412 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4413 should eventually go away. We could either create two loops properly,
4414 or find another way to save/restore the array offsets between the two
4415 loops (without conflicting with temporary management), or use a single
4416 loop minmaxval implementation. See PR 31067. */
4417 loop.temp_dim = loop.dimen;
4418 gfc_conv_loop_setup (&loop, &expr->where);
4419
4420 if (nonempty == NULL && maskss == NULL
4421 && loop.dimen == 1 && loop.from[0] && loop.to[0])
4422 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
4423 loop.from[0], loop.to[0]);
4424 nonempty_var = NULL;
4425 if (nonempty == NULL
4426 && (HONOR_INFINITIES (DECL_MODE (limit))
4427 || HONOR_NANS (DECL_MODE (limit))))
4428 {
4429 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
4430 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
4431 nonempty = nonempty_var;
4432 }
4433 lab = NULL;
4434 fast = NULL;
4435 if (HONOR_NANS (DECL_MODE (limit)))
4436 {
4437 if (loop.dimen == 1)
4438 {
4439 lab = gfc_build_label_decl (NULL_TREE);
4440 TREE_USED (lab) = 1;
4441 }
4442 else
4443 {
4444 fast = gfc_create_var (boolean_type_node, "fast");
4445 gfc_add_modify (&se->pre, fast, boolean_false_node);
4446 }
4447 }
4448
4449 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
4450 if (maskss)
4451 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
4452 /* Generate the loop body. */
4453 gfc_start_scalarized_body (&loop, &body);
4454
4455 /* If we have a mask, only add this element if the mask is set. */
4456 if (maskss)
4457 {
4458 gfc_init_se (&maskse, NULL);
4459 gfc_copy_loopinfo_to_se (&maskse, &loop);
4460 maskse.ss = maskss;
4461 gfc_conv_expr_val (&maskse, maskexpr);
4462 gfc_add_block_to_block (&body, &maskse.pre);
4463
4464 gfc_start_block (&block);
4465 }
4466 else
4467 gfc_init_block (&block);
4468
4469 /* Compare with the current limit. */
4470 gfc_init_se (&arrayse, NULL);
4471 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4472 arrayse.ss = arrayss;
4473 gfc_conv_expr_val (&arrayse, arrayexpr);
4474 gfc_add_block_to_block (&block, &arrayse.pre);
4475
4476 gfc_init_block (&block2);
4477
4478 if (nonempty_var)
4479 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
4480
4481 if (HONOR_NANS (DECL_MODE (limit)))
4482 {
4483 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
4484 boolean_type_node, arrayse.expr, limit);
4485 if (lab)
4486 ifbody = build1_v (GOTO_EXPR, lab);
4487 else
4488 {
4489 stmtblock_t ifblock;
4490
4491 gfc_init_block (&ifblock);
4492 gfc_add_modify (&ifblock, limit, arrayse.expr);
4493 gfc_add_modify (&ifblock, fast, boolean_true_node);
4494 ifbody = gfc_finish_block (&ifblock);
4495 }
4496 tmp = build3_v (COND_EXPR, tmp, ifbody,
4497 build_empty_stmt (input_location));
4498 gfc_add_expr_to_block (&block2, tmp);
4499 }
4500 else
4501 {
4502 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4503 signed zeros. */
4504 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
4505 {
4506 tmp = fold_build2_loc (input_location, op, boolean_type_node,
4507 arrayse.expr, limit);
4508 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
4509 tmp = build3_v (COND_EXPR, tmp, ifbody,
4510 build_empty_stmt (input_location));
4511 gfc_add_expr_to_block (&block2, tmp);
4512 }
4513 else
4514 {
4515 tmp = fold_build2_loc (input_location,
4516 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
4517 type, arrayse.expr, limit);
4518 gfc_add_modify (&block2, limit, tmp);
4519 }
4520 }
4521
4522 if (fast)
4523 {
4524 tree elsebody = gfc_finish_block (&block2);
4525
4526 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4527 signed zeros. */
4528 if (HONOR_NANS (DECL_MODE (limit))
4529 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
4530 {
4531 tmp = fold_build2_loc (input_location, op, boolean_type_node,
4532 arrayse.expr, limit);
4533 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
4534 ifbody = build3_v (COND_EXPR, tmp, ifbody,
4535 build_empty_stmt (input_location));
4536 }
4537 else
4538 {
4539 tmp = fold_build2_loc (input_location,
4540 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
4541 type, arrayse.expr, limit);
4542 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
4543 }
4544 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
4545 gfc_add_expr_to_block (&block, tmp);
4546 }
4547 else
4548 gfc_add_block_to_block (&block, &block2);
4549
4550 gfc_add_block_to_block (&block, &arrayse.post);
4551
4552 tmp = gfc_finish_block (&block);
4553 if (maskss)
4554 /* We enclose the above in if (mask) {...}. */
4555 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4556 build_empty_stmt (input_location));
4557 gfc_add_expr_to_block (&body, tmp);
4558
4559 if (lab)
4560 {
4561 gfc_trans_scalarized_loop_boundary (&loop, &body);
4562
4563 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
4564 nan_cst, huge_cst);
4565 gfc_add_modify (&loop.code[0], limit, tmp);
4566 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
4567
4568 /* If we have a mask, only add this element if the mask is set. */
4569 if (maskss)
4570 {
4571 gfc_init_se (&maskse, NULL);
4572 gfc_copy_loopinfo_to_se (&maskse, &loop);
4573 maskse.ss = maskss;
4574 gfc_conv_expr_val (&maskse, maskexpr);
4575 gfc_add_block_to_block (&body, &maskse.pre);
4576
4577 gfc_start_block (&block);
4578 }
4579 else
4580 gfc_init_block (&block);
4581
4582 /* Compare with the current limit. */
4583 gfc_init_se (&arrayse, NULL);
4584 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4585 arrayse.ss = arrayss;
4586 gfc_conv_expr_val (&arrayse, arrayexpr);
4587 gfc_add_block_to_block (&block, &arrayse.pre);
4588
4589 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4590 signed zeros. */
4591 if (HONOR_NANS (DECL_MODE (limit))
4592 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
4593 {
4594 tmp = fold_build2_loc (input_location, op, boolean_type_node,
4595 arrayse.expr, limit);
4596 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
4597 tmp = build3_v (COND_EXPR, tmp, ifbody,
4598 build_empty_stmt (input_location));
4599 gfc_add_expr_to_block (&block, tmp);
4600 }
4601 else
4602 {
4603 tmp = fold_build2_loc (input_location,
4604 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
4605 type, arrayse.expr, limit);
4606 gfc_add_modify (&block, limit, tmp);
4607 }
4608
4609 gfc_add_block_to_block (&block, &arrayse.post);
4610
4611 tmp = gfc_finish_block (&block);
4612 if (maskss)
4613 /* We enclose the above in if (mask) {...}. */
4614 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4615 build_empty_stmt (input_location));
4616 gfc_add_expr_to_block (&body, tmp);
4617 /* Avoid initializing loopvar[0] again, it should be left where
4618 it finished by the first loop. */
4619 loop.from[0] = loop.loopvar[0];
4620 }
4621 gfc_trans_scalarizing_loops (&loop, &body);
4622
4623 if (fast)
4624 {
4625 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
4626 nan_cst, huge_cst);
4627 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
4628 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
4629 ifbody);
4630 gfc_add_expr_to_block (&loop.pre, tmp);
4631 }
4632 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
4633 {
4634 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
4635 huge_cst);
4636 gfc_add_modify (&loop.pre, limit, tmp);
4637 }
4638
4639 /* For a scalar mask, enclose the loop in an if statement. */
4640 if (maskexpr && maskss == NULL)
4641 {
4642 tree else_stmt;
4643
4644 gfc_init_se (&maskse, NULL);
4645 gfc_conv_expr_val (&maskse, maskexpr);
4646 gfc_init_block (&block);
4647 gfc_add_block_to_block (&block, &loop.pre);
4648 gfc_add_block_to_block (&block, &loop.post);
4649 tmp = gfc_finish_block (&block);
4650
4651 if (HONOR_INFINITIES (DECL_MODE (limit)))
4652 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
4653 else
4654 else_stmt = build_empty_stmt (input_location);
4655 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
4656 gfc_add_expr_to_block (&block, tmp);
4657 gfc_add_block_to_block (&se->pre, &block);
4658 }
4659 else
4660 {
4661 gfc_add_block_to_block (&se->pre, &loop.pre);
4662 gfc_add_block_to_block (&se->pre, &loop.post);
4663 }
4664
4665 gfc_cleanup_loop (&loop);
4666
4667 se->expr = limit;
4668 }
4669
4670 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4671 static void
gfc_conv_intrinsic_btest(gfc_se * se,gfc_expr * expr)4672 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
4673 {
4674 tree args[2];
4675 tree type;
4676 tree tmp;
4677
4678 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4679 type = TREE_TYPE (args[0]);
4680
4681 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
4682 build_int_cst (type, 1), args[1]);
4683 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
4684 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
4685 build_int_cst (type, 0));
4686 type = gfc_typenode_for_spec (&expr->ts);
4687 se->expr = convert (type, tmp);
4688 }
4689
4690
4691 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4692 static void
gfc_conv_intrinsic_bitcomp(gfc_se * se,gfc_expr * expr,enum tree_code op)4693 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
4694 {
4695 tree args[2];
4696
4697 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4698
4699 /* Convert both arguments to the unsigned type of the same size. */
4700 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
4701 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
4702
4703 /* If they have unequal type size, convert to the larger one. */
4704 if (TYPE_PRECISION (TREE_TYPE (args[0]))
4705 > TYPE_PRECISION (TREE_TYPE (args[1])))
4706 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
4707 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
4708 > TYPE_PRECISION (TREE_TYPE (args[0])))
4709 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
4710
4711 /* Now, we compare them. */
4712 se->expr = fold_build2_loc (input_location, op, boolean_type_node,
4713 args[0], args[1]);
4714 }
4715
4716
4717 /* Generate code to perform the specified operation. */
4718 static void
gfc_conv_intrinsic_bitop(gfc_se * se,gfc_expr * expr,enum tree_code op)4719 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
4720 {
4721 tree args[2];
4722
4723 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4724 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
4725 args[0], args[1]);
4726 }
4727
4728 /* Bitwise not. */
4729 static void
gfc_conv_intrinsic_not(gfc_se * se,gfc_expr * expr)4730 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
4731 {
4732 tree arg;
4733
4734 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4735 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
4736 TREE_TYPE (arg), arg);
4737 }
4738
4739 /* Set or clear a single bit. */
4740 static void
gfc_conv_intrinsic_singlebitop(gfc_se * se,gfc_expr * expr,int set)4741 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
4742 {
4743 tree args[2];
4744 tree type;
4745 tree tmp;
4746 enum tree_code op;
4747
4748 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4749 type = TREE_TYPE (args[0]);
4750
4751 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
4752 build_int_cst (type, 1), args[1]);
4753 if (set)
4754 op = BIT_IOR_EXPR;
4755 else
4756 {
4757 op = BIT_AND_EXPR;
4758 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
4759 }
4760 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
4761 }
4762
4763 /* Extract a sequence of bits.
4764 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4765 static void
gfc_conv_intrinsic_ibits(gfc_se * se,gfc_expr * expr)4766 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
4767 {
4768 tree args[3];
4769 tree type;
4770 tree tmp;
4771 tree mask;
4772
4773 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4774 type = TREE_TYPE (args[0]);
4775
4776 mask = build_int_cst (type, -1);
4777 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
4778 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
4779
4780 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
4781
4782 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
4783 }
4784
4785 static void
gfc_conv_intrinsic_shape(gfc_se * se,gfc_expr * expr)4786 gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
4787 {
4788 gfc_actual_arglist *s, *k;
4789 gfc_expr *e;
4790
4791 /* Remove the KIND argument, if present. */
4792 s = expr->value.function.actual;
4793 k = s->next;
4794 e = k->expr;
4795 gfc_free_expr (e);
4796 k->expr = NULL;
4797
4798 gfc_conv_intrinsic_funcall (se, expr);
4799 }
4800
4801 static void
gfc_conv_intrinsic_shift(gfc_se * se,gfc_expr * expr,bool right_shift,bool arithmetic)4802 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
4803 bool arithmetic)
4804 {
4805 tree args[2], type, num_bits, cond;
4806
4807 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4808
4809 args[0] = gfc_evaluate_now (args[0], &se->pre);
4810 args[1] = gfc_evaluate_now (args[1], &se->pre);
4811 type = TREE_TYPE (args[0]);
4812
4813 if (!arithmetic)
4814 args[0] = fold_convert (unsigned_type_for (type), args[0]);
4815 else
4816 gcc_assert (right_shift);
4817
4818 se->expr = fold_build2_loc (input_location,
4819 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
4820 TREE_TYPE (args[0]), args[0], args[1]);
4821
4822 if (!arithmetic)
4823 se->expr = fold_convert (type, se->expr);
4824
4825 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4826 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4827 special case. */
4828 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
4829 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4830 args[1], num_bits);
4831
4832 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
4833 build_int_cst (type, 0), se->expr);
4834 }
4835
4836 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4837 ? 0
4838 : ((shift >= 0) ? i << shift : i >> -shift)
4839 where all shifts are logical shifts. */
4840 static void
gfc_conv_intrinsic_ishft(gfc_se * se,gfc_expr * expr)4841 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
4842 {
4843 tree args[2];
4844 tree type;
4845 tree utype;
4846 tree tmp;
4847 tree width;
4848 tree num_bits;
4849 tree cond;
4850 tree lshift;
4851 tree rshift;
4852
4853 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4854
4855 args[0] = gfc_evaluate_now (args[0], &se->pre);
4856 args[1] = gfc_evaluate_now (args[1], &se->pre);
4857
4858 type = TREE_TYPE (args[0]);
4859 utype = unsigned_type_for (type);
4860
4861 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
4862 args[1]);
4863
4864 /* Left shift if positive. */
4865 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
4866
4867 /* Right shift if negative.
4868 We convert to an unsigned type because we want a logical shift.
4869 The standard doesn't define the case of shifting negative
4870 numbers, and we try to be compatible with other compilers, most
4871 notably g77, here. */
4872 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
4873 utype, convert (utype, args[0]), width));
4874
4875 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
4876 build_int_cst (TREE_TYPE (args[1]), 0));
4877 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
4878
4879 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4880 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4881 special case. */
4882 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
4883 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
4884 num_bits);
4885 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
4886 build_int_cst (type, 0), tmp);
4887 }
4888
4889
4890 /* Circular shift. AKA rotate or barrel shift. */
4891
4892 static void
gfc_conv_intrinsic_ishftc(gfc_se * se,gfc_expr * expr)4893 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
4894 {
4895 tree *args;
4896 tree type;
4897 tree tmp;
4898 tree lrot;
4899 tree rrot;
4900 tree zero;
4901 unsigned int num_args;
4902
4903 num_args = gfc_intrinsic_argument_list_length (expr);
4904 args = XALLOCAVEC (tree, num_args);
4905
4906 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4907
4908 if (num_args == 3)
4909 {
4910 /* Use a library function for the 3 parameter version. */
4911 tree int4type = gfc_get_int_type (4);
4912
4913 type = TREE_TYPE (args[0]);
4914 /* We convert the first argument to at least 4 bytes, and
4915 convert back afterwards. This removes the need for library
4916 functions for all argument sizes, and function will be
4917 aligned to at least 32 bits, so there's no loss. */
4918 if (expr->ts.kind < 4)
4919 args[0] = convert (int4type, args[0]);
4920
4921 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4922 need loads of library functions. They cannot have values >
4923 BIT_SIZE (I) so the conversion is safe. */
4924 args[1] = convert (int4type, args[1]);
4925 args[2] = convert (int4type, args[2]);
4926
4927 switch (expr->ts.kind)
4928 {
4929 case 1:
4930 case 2:
4931 case 4:
4932 tmp = gfor_fndecl_math_ishftc4;
4933 break;
4934 case 8:
4935 tmp = gfor_fndecl_math_ishftc8;
4936 break;
4937 case 16:
4938 tmp = gfor_fndecl_math_ishftc16;
4939 break;
4940 default:
4941 gcc_unreachable ();
4942 }
4943 se->expr = build_call_expr_loc (input_location,
4944 tmp, 3, args[0], args[1], args[2]);
4945 /* Convert the result back to the original type, if we extended
4946 the first argument's width above. */
4947 if (expr->ts.kind < 4)
4948 se->expr = convert (type, se->expr);
4949
4950 return;
4951 }
4952 type = TREE_TYPE (args[0]);
4953
4954 /* Evaluate arguments only once. */
4955 args[0] = gfc_evaluate_now (args[0], &se->pre);
4956 args[1] = gfc_evaluate_now (args[1], &se->pre);
4957
4958 /* Rotate left if positive. */
4959 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
4960
4961 /* Rotate right if negative. */
4962 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
4963 args[1]);
4964 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
4965
4966 zero = build_int_cst (TREE_TYPE (args[1]), 0);
4967 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
4968 zero);
4969 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
4970
4971 /* Do nothing if shift == 0. */
4972 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
4973 zero);
4974 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
4975 rrot);
4976 }
4977
4978
4979 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4980 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4981
4982 The conditional expression is necessary because the result of LEADZ(0)
4983 is defined, but the result of __builtin_clz(0) is undefined for most
4984 targets.
4985
4986 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4987 difference in bit size between the argument of LEADZ and the C int. */
4988
4989 static void
gfc_conv_intrinsic_leadz(gfc_se * se,gfc_expr * expr)4990 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
4991 {
4992 tree arg;
4993 tree arg_type;
4994 tree cond;
4995 tree result_type;
4996 tree leadz;
4997 tree bit_size;
4998 tree tmp;
4999 tree func;
5000 int s, argsize;
5001
5002 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5003 argsize = TYPE_PRECISION (TREE_TYPE (arg));
5004
5005 /* Which variant of __builtin_clz* should we call? */
5006 if (argsize <= INT_TYPE_SIZE)
5007 {
5008 arg_type = unsigned_type_node;
5009 func = builtin_decl_explicit (BUILT_IN_CLZ);
5010 }
5011 else if (argsize <= LONG_TYPE_SIZE)
5012 {
5013 arg_type = long_unsigned_type_node;
5014 func = builtin_decl_explicit (BUILT_IN_CLZL);
5015 }
5016 else if (argsize <= LONG_LONG_TYPE_SIZE)
5017 {
5018 arg_type = long_long_unsigned_type_node;
5019 func = builtin_decl_explicit (BUILT_IN_CLZLL);
5020 }
5021 else
5022 {
5023 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5024 arg_type = gfc_build_uint_type (argsize);
5025 func = NULL_TREE;
5026 }
5027
5028 /* Convert the actual argument twice: first, to the unsigned type of the
5029 same size; then, to the proper argument type for the built-in
5030 function. But the return type is of the default INTEGER kind. */
5031 arg = fold_convert (gfc_build_uint_type (argsize), arg);
5032 arg = fold_convert (arg_type, arg);
5033 arg = gfc_evaluate_now (arg, &se->pre);
5034 result_type = gfc_get_int_type (gfc_default_integer_kind);
5035
5036 /* Compute LEADZ for the case i .ne. 0. */
5037 if (func)
5038 {
5039 s = TYPE_PRECISION (arg_type) - argsize;
5040 tmp = fold_convert (result_type,
5041 build_call_expr_loc (input_location, func,
5042 1, arg));
5043 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
5044 tmp, build_int_cst (result_type, s));
5045 }
5046 else
5047 {
5048 /* We end up here if the argument type is larger than 'long long'.
5049 We generate this code:
5050
5051 if (x & (ULL_MAX << ULL_SIZE) != 0)
5052 return clzll ((unsigned long long) (x >> ULLSIZE));
5053 else
5054 return ULL_SIZE + clzll ((unsigned long long) x);
5055 where ULL_MAX is the largest value that a ULL_MAX can hold
5056 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5057 is the bit-size of the long long type (64 in this example). */
5058 tree ullsize, ullmax, tmp1, tmp2, btmp;
5059
5060 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
5061 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
5062 long_long_unsigned_type_node,
5063 build_int_cst (long_long_unsigned_type_node,
5064 0));
5065
5066 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
5067 fold_convert (arg_type, ullmax), ullsize);
5068 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
5069 arg, cond);
5070 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5071 cond, build_int_cst (arg_type, 0));
5072
5073 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
5074 arg, ullsize);
5075 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
5076 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5077 tmp1 = fold_convert (result_type,
5078 build_call_expr_loc (input_location, btmp, 1, tmp1));
5079
5080 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
5081 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5082 tmp2 = fold_convert (result_type,
5083 build_call_expr_loc (input_location, btmp, 1, tmp2));
5084 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5085 tmp2, ullsize);
5086
5087 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
5088 cond, tmp1, tmp2);
5089 }
5090
5091 /* Build BIT_SIZE. */
5092 bit_size = build_int_cst (result_type, argsize);
5093
5094 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5095 arg, build_int_cst (arg_type, 0));
5096 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
5097 bit_size, leadz);
5098 }
5099
5100
5101 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5102
5103 The conditional expression is necessary because the result of TRAILZ(0)
5104 is defined, but the result of __builtin_ctz(0) is undefined for most
5105 targets. */
5106
5107 static void
gfc_conv_intrinsic_trailz(gfc_se * se,gfc_expr * expr)5108 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
5109 {
5110 tree arg;
5111 tree arg_type;
5112 tree cond;
5113 tree result_type;
5114 tree trailz;
5115 tree bit_size;
5116 tree func;
5117 int argsize;
5118
5119 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5120 argsize = TYPE_PRECISION (TREE_TYPE (arg));
5121
5122 /* Which variant of __builtin_ctz* should we call? */
5123 if (argsize <= INT_TYPE_SIZE)
5124 {
5125 arg_type = unsigned_type_node;
5126 func = builtin_decl_explicit (BUILT_IN_CTZ);
5127 }
5128 else if (argsize <= LONG_TYPE_SIZE)
5129 {
5130 arg_type = long_unsigned_type_node;
5131 func = builtin_decl_explicit (BUILT_IN_CTZL);
5132 }
5133 else if (argsize <= LONG_LONG_TYPE_SIZE)
5134 {
5135 arg_type = long_long_unsigned_type_node;
5136 func = builtin_decl_explicit (BUILT_IN_CTZLL);
5137 }
5138 else
5139 {
5140 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5141 arg_type = gfc_build_uint_type (argsize);
5142 func = NULL_TREE;
5143 }
5144
5145 /* Convert the actual argument twice: first, to the unsigned type of the
5146 same size; then, to the proper argument type for the built-in
5147 function. But the return type is of the default INTEGER kind. */
5148 arg = fold_convert (gfc_build_uint_type (argsize), arg);
5149 arg = fold_convert (arg_type, arg);
5150 arg = gfc_evaluate_now (arg, &se->pre);
5151 result_type = gfc_get_int_type (gfc_default_integer_kind);
5152
5153 /* Compute TRAILZ for the case i .ne. 0. */
5154 if (func)
5155 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
5156 func, 1, arg));
5157 else
5158 {
5159 /* We end up here if the argument type is larger than 'long long'.
5160 We generate this code:
5161
5162 if ((x & ULL_MAX) == 0)
5163 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5164 else
5165 return ctzll ((unsigned long long) x);
5166
5167 where ULL_MAX is the largest value that a ULL_MAX can hold
5168 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5169 is the bit-size of the long long type (64 in this example). */
5170 tree ullsize, ullmax, tmp1, tmp2, btmp;
5171
5172 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
5173 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
5174 long_long_unsigned_type_node,
5175 build_int_cst (long_long_unsigned_type_node, 0));
5176
5177 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
5178 fold_convert (arg_type, ullmax));
5179 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
5180 build_int_cst (arg_type, 0));
5181
5182 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
5183 arg, ullsize);
5184 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
5185 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
5186 tmp1 = fold_convert (result_type,
5187 build_call_expr_loc (input_location, btmp, 1, tmp1));
5188 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5189 tmp1, ullsize);
5190
5191 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
5192 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
5193 tmp2 = fold_convert (result_type,
5194 build_call_expr_loc (input_location, btmp, 1, tmp2));
5195
5196 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
5197 cond, tmp1, tmp2);
5198 }
5199
5200 /* Build BIT_SIZE. */
5201 bit_size = build_int_cst (result_type, argsize);
5202
5203 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5204 arg, build_int_cst (arg_type, 0));
5205 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
5206 bit_size, trailz);
5207 }
5208
5209 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5210 for types larger than "long long", we call the long long built-in for
5211 the lower and higher bits and combine the result. */
5212
5213 static void
gfc_conv_intrinsic_popcnt_poppar(gfc_se * se,gfc_expr * expr,int parity)5214 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
5215 {
5216 tree arg;
5217 tree arg_type;
5218 tree result_type;
5219 tree func;
5220 int argsize;
5221
5222 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5223 argsize = TYPE_PRECISION (TREE_TYPE (arg));
5224 result_type = gfc_get_int_type (gfc_default_integer_kind);
5225
5226 /* Which variant of the builtin should we call? */
5227 if (argsize <= INT_TYPE_SIZE)
5228 {
5229 arg_type = unsigned_type_node;
5230 func = builtin_decl_explicit (parity
5231 ? BUILT_IN_PARITY
5232 : BUILT_IN_POPCOUNT);
5233 }
5234 else if (argsize <= LONG_TYPE_SIZE)
5235 {
5236 arg_type = long_unsigned_type_node;
5237 func = builtin_decl_explicit (parity
5238 ? BUILT_IN_PARITYL
5239 : BUILT_IN_POPCOUNTL);
5240 }
5241 else if (argsize <= LONG_LONG_TYPE_SIZE)
5242 {
5243 arg_type = long_long_unsigned_type_node;
5244 func = builtin_decl_explicit (parity
5245 ? BUILT_IN_PARITYLL
5246 : BUILT_IN_POPCOUNTLL);
5247 }
5248 else
5249 {
5250 /* Our argument type is larger than 'long long', which mean none
5251 of the POPCOUNT builtins covers it. We thus call the 'long long'
5252 variant multiple times, and add the results. */
5253 tree utype, arg2, call1, call2;
5254
5255 /* For now, we only cover the case where argsize is twice as large
5256 as 'long long'. */
5257 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5258
5259 func = builtin_decl_explicit (parity
5260 ? BUILT_IN_PARITYLL
5261 : BUILT_IN_POPCOUNTLL);
5262
5263 /* Convert it to an integer, and store into a variable. */
5264 utype = gfc_build_uint_type (argsize);
5265 arg = fold_convert (utype, arg);
5266 arg = gfc_evaluate_now (arg, &se->pre);
5267
5268 /* Call the builtin twice. */
5269 call1 = build_call_expr_loc (input_location, func, 1,
5270 fold_convert (long_long_unsigned_type_node,
5271 arg));
5272
5273 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
5274 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
5275 call2 = build_call_expr_loc (input_location, func, 1,
5276 fold_convert (long_long_unsigned_type_node,
5277 arg2));
5278
5279 /* Combine the results. */
5280 if (parity)
5281 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
5282 call1, call2);
5283 else
5284 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5285 call1, call2);
5286
5287 return;
5288 }
5289
5290 /* Convert the actual argument twice: first, to the unsigned type of the
5291 same size; then, to the proper argument type for the built-in
5292 function. */
5293 arg = fold_convert (gfc_build_uint_type (argsize), arg);
5294 arg = fold_convert (arg_type, arg);
5295
5296 se->expr = fold_convert (result_type,
5297 build_call_expr_loc (input_location, func, 1, arg));
5298 }
5299
5300
5301 /* Process an intrinsic with unspecified argument-types that has an optional
5302 argument (which could be of type character), e.g. EOSHIFT. For those, we
5303 need to append the string length of the optional argument if it is not
5304 present and the type is really character.
5305 primary specifies the position (starting at 1) of the non-optional argument
5306 specifying the type and optional gives the position of the optional
5307 argument in the arglist. */
5308
5309 static void
conv_generic_with_optional_char_arg(gfc_se * se,gfc_expr * expr,unsigned primary,unsigned optional)5310 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
5311 unsigned primary, unsigned optional)
5312 {
5313 gfc_actual_arglist* prim_arg;
5314 gfc_actual_arglist* opt_arg;
5315 unsigned cur_pos;
5316 gfc_actual_arglist* arg;
5317 gfc_symbol* sym;
5318 vec<tree, va_gc> *append_args;
5319
5320 /* Find the two arguments given as position. */
5321 cur_pos = 0;
5322 prim_arg = NULL;
5323 opt_arg = NULL;
5324 for (arg = expr->value.function.actual; arg; arg = arg->next)
5325 {
5326 ++cur_pos;
5327
5328 if (cur_pos == primary)
5329 prim_arg = arg;
5330 if (cur_pos == optional)
5331 opt_arg = arg;
5332
5333 if (cur_pos >= primary && cur_pos >= optional)
5334 break;
5335 }
5336 gcc_assert (prim_arg);
5337 gcc_assert (prim_arg->expr);
5338 gcc_assert (opt_arg);
5339
5340 /* If we do have type CHARACTER and the optional argument is really absent,
5341 append a dummy 0 as string length. */
5342 append_args = NULL;
5343 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
5344 {
5345 tree dummy;
5346
5347 dummy = build_int_cst (gfc_charlen_type_node, 0);
5348 vec_alloc (append_args, 1);
5349 append_args->quick_push (dummy);
5350 }
5351
5352 /* Build the call itself. */
5353 gcc_assert (!se->ignore_optional);
5354 sym = gfc_get_symbol_for_expr (expr, false);
5355 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
5356 append_args);
5357 gfc_free_symbol (sym);
5358 }
5359
5360
5361 /* The length of a character string. */
5362 static void
gfc_conv_intrinsic_len(gfc_se * se,gfc_expr * expr)5363 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
5364 {
5365 tree len;
5366 tree type;
5367 tree decl;
5368 gfc_symbol *sym;
5369 gfc_se argse;
5370 gfc_expr *arg;
5371
5372 gcc_assert (!se->ss);
5373
5374 arg = expr->value.function.actual->expr;
5375
5376 type = gfc_typenode_for_spec (&expr->ts);
5377 switch (arg->expr_type)
5378 {
5379 case EXPR_CONSTANT:
5380 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
5381 break;
5382
5383 case EXPR_ARRAY:
5384 /* Obtain the string length from the function used by
5385 trans-array.c(gfc_trans_array_constructor). */
5386 len = NULL_TREE;
5387 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
5388 break;
5389
5390 case EXPR_VARIABLE:
5391 if (arg->ref == NULL
5392 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
5393 {
5394 /* This doesn't catch all cases.
5395 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5396 and the surrounding thread. */
5397 sym = arg->symtree->n.sym;
5398 decl = gfc_get_symbol_decl (sym);
5399 if (decl == current_function_decl && sym->attr.function
5400 && (sym->result == sym))
5401 decl = gfc_get_fake_result_decl (sym, 0);
5402
5403 len = sym->ts.u.cl->backend_decl;
5404 gcc_assert (len);
5405 break;
5406 }
5407
5408 /* Otherwise fall through. */
5409
5410 default:
5411 /* Anybody stupid enough to do this deserves inefficient code. */
5412 gfc_init_se (&argse, se);
5413 if (arg->rank == 0)
5414 gfc_conv_expr (&argse, arg);
5415 else
5416 gfc_conv_expr_descriptor (&argse, arg);
5417 gfc_add_block_to_block (&se->pre, &argse.pre);
5418 gfc_add_block_to_block (&se->post, &argse.post);
5419 len = argse.string_length;
5420 break;
5421 }
5422 se->expr = convert (type, len);
5423 }
5424
5425 /* The length of a character string not including trailing blanks. */
5426 static void
gfc_conv_intrinsic_len_trim(gfc_se * se,gfc_expr * expr)5427 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
5428 {
5429 int kind = expr->value.function.actual->expr->ts.kind;
5430 tree args[2], type, fndecl;
5431
5432 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5433 type = gfc_typenode_for_spec (&expr->ts);
5434
5435 if (kind == 1)
5436 fndecl = gfor_fndecl_string_len_trim;
5437 else if (kind == 4)
5438 fndecl = gfor_fndecl_string_len_trim_char4;
5439 else
5440 gcc_unreachable ();
5441
5442 se->expr = build_call_expr_loc (input_location,
5443 fndecl, 2, args[0], args[1]);
5444 se->expr = convert (type, se->expr);
5445 }
5446
5447
5448 /* Returns the starting position of a substring within a string. */
5449
5450 static void
gfc_conv_intrinsic_index_scan_verify(gfc_se * se,gfc_expr * expr,tree function)5451 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
5452 tree function)
5453 {
5454 tree logical4_type_node = gfc_get_logical_type (4);
5455 tree type;
5456 tree fndecl;
5457 tree *args;
5458 unsigned int num_args;
5459
5460 args = XALLOCAVEC (tree, 5);
5461
5462 /* Get number of arguments; characters count double due to the
5463 string length argument. Kind= is not passed to the library
5464 and thus ignored. */
5465 if (expr->value.function.actual->next->next->expr == NULL)
5466 num_args = 4;
5467 else
5468 num_args = 5;
5469
5470 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
5471 type = gfc_typenode_for_spec (&expr->ts);
5472
5473 if (num_args == 4)
5474 args[4] = build_int_cst (logical4_type_node, 0);
5475 else
5476 args[4] = convert (logical4_type_node, args[4]);
5477
5478 fndecl = build_addr (function);
5479 se->expr = build_call_array_loc (input_location,
5480 TREE_TYPE (TREE_TYPE (function)), fndecl,
5481 5, args);
5482 se->expr = convert (type, se->expr);
5483
5484 }
5485
5486 /* The ascii value for a single character. */
5487 static void
gfc_conv_intrinsic_ichar(gfc_se * se,gfc_expr * expr)5488 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
5489 {
5490 tree args[3], type, pchartype;
5491 int nargs;
5492
5493 nargs = gfc_intrinsic_argument_list_length (expr);
5494 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
5495 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
5496 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
5497 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
5498 type = gfc_typenode_for_spec (&expr->ts);
5499
5500 se->expr = build_fold_indirect_ref_loc (input_location,
5501 args[1]);
5502 se->expr = convert (type, se->expr);
5503 }
5504
5505
5506 /* Intrinsic ISNAN calls __builtin_isnan. */
5507
5508 static void
gfc_conv_intrinsic_isnan(gfc_se * se,gfc_expr * expr)5509 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
5510 {
5511 tree arg;
5512
5513 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5514 se->expr = build_call_expr_loc (input_location,
5515 builtin_decl_explicit (BUILT_IN_ISNAN),
5516 1, arg);
5517 STRIP_TYPE_NOPS (se->expr);
5518 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5519 }
5520
5521
5522 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5523 their argument against a constant integer value. */
5524
5525 static void
gfc_conv_has_intvalue(gfc_se * se,gfc_expr * expr,const int value)5526 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
5527 {
5528 tree arg;
5529
5530 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5531 se->expr = fold_build2_loc (input_location, EQ_EXPR,
5532 gfc_typenode_for_spec (&expr->ts),
5533 arg, build_int_cst (TREE_TYPE (arg), value));
5534 }
5535
5536
5537
5538 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5539
5540 static void
gfc_conv_intrinsic_merge(gfc_se * se,gfc_expr * expr)5541 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
5542 {
5543 tree tsource;
5544 tree fsource;
5545 tree mask;
5546 tree type;
5547 tree len, len2;
5548 tree *args;
5549 unsigned int num_args;
5550
5551 num_args = gfc_intrinsic_argument_list_length (expr);
5552 args = XALLOCAVEC (tree, num_args);
5553
5554 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
5555 if (expr->ts.type != BT_CHARACTER)
5556 {
5557 tsource = args[0];
5558 fsource = args[1];
5559 mask = args[2];
5560 }
5561 else
5562 {
5563 /* We do the same as in the non-character case, but the argument
5564 list is different because of the string length arguments. We
5565 also have to set the string length for the result. */
5566 len = args[0];
5567 tsource = args[1];
5568 len2 = args[2];
5569 fsource = args[3];
5570 mask = args[4];
5571
5572 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
5573 &se->pre);
5574 se->string_length = len;
5575 }
5576 type = TREE_TYPE (tsource);
5577 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
5578 fold_convert (type, fsource));
5579 }
5580
5581
5582 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5583
5584 static void
gfc_conv_intrinsic_merge_bits(gfc_se * se,gfc_expr * expr)5585 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
5586 {
5587 tree args[3], mask, type;
5588
5589 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5590 mask = gfc_evaluate_now (args[2], &se->pre);
5591
5592 type = TREE_TYPE (args[0]);
5593 gcc_assert (TREE_TYPE (args[1]) == type);
5594 gcc_assert (TREE_TYPE (mask) == type);
5595
5596 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
5597 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
5598 fold_build1_loc (input_location, BIT_NOT_EXPR,
5599 type, mask));
5600 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
5601 args[0], args[1]);
5602 }
5603
5604
5605 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5606 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5607
5608 static void
gfc_conv_intrinsic_mask(gfc_se * se,gfc_expr * expr,int left)5609 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
5610 {
5611 tree arg, allones, type, utype, res, cond, bitsize;
5612 int i;
5613
5614 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5615 arg = gfc_evaluate_now (arg, &se->pre);
5616
5617 type = gfc_get_int_type (expr->ts.kind);
5618 utype = unsigned_type_for (type);
5619
5620 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
5621 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
5622
5623 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
5624 build_int_cst (utype, 0));
5625
5626 if (left)
5627 {
5628 /* Left-justified mask. */
5629 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
5630 bitsize, arg);
5631 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
5632 fold_convert (utype, res));
5633
5634 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5635 smaller than type width. */
5636 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
5637 build_int_cst (TREE_TYPE (arg), 0));
5638 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
5639 build_int_cst (utype, 0), res);
5640 }
5641 else
5642 {
5643 /* Right-justified mask. */
5644 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
5645 fold_convert (utype, arg));
5646 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
5647
5648 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5649 strictly smaller than type width. */
5650 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5651 arg, bitsize);
5652 res = fold_build3_loc (input_location, COND_EXPR, utype,
5653 cond, allones, res);
5654 }
5655
5656 se->expr = fold_convert (type, res);
5657 }
5658
5659
5660 /* FRACTION (s) is translated into:
5661 isfinite (s) ? frexp (s, &dummy_int) : NaN */
5662 static void
gfc_conv_intrinsic_fraction(gfc_se * se,gfc_expr * expr)5663 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
5664 {
5665 tree arg, type, tmp, res, frexp, cond;
5666
5667 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
5668
5669 type = gfc_typenode_for_spec (&expr->ts);
5670 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5671 arg = gfc_evaluate_now (arg, &se->pre);
5672
5673 cond = build_call_expr_loc (input_location,
5674 builtin_decl_explicit (BUILT_IN_ISFINITE),
5675 1, arg);
5676
5677 tmp = gfc_create_var (integer_type_node, NULL);
5678 res = build_call_expr_loc (input_location, frexp, 2,
5679 fold_convert (type, arg),
5680 gfc_build_addr_expr (NULL_TREE, tmp));
5681 res = fold_convert (type, res);
5682
5683 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
5684 cond, res, gfc_build_nan (type, ""));
5685 }
5686
5687
5688 /* NEAREST (s, dir) is translated into
5689 tmp = copysign (HUGE_VAL, dir);
5690 return nextafter (s, tmp);
5691 */
5692 static void
gfc_conv_intrinsic_nearest(gfc_se * se,gfc_expr * expr)5693 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
5694 {
5695 tree args[2], type, tmp, nextafter, copysign, huge_val;
5696
5697 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
5698 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
5699
5700 type = gfc_typenode_for_spec (&expr->ts);
5701 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5702
5703 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
5704 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
5705 fold_convert (type, args[1]));
5706 se->expr = build_call_expr_loc (input_location, nextafter, 2,
5707 fold_convert (type, args[0]), tmp);
5708 se->expr = fold_convert (type, se->expr);
5709 }
5710
5711
5712 /* SPACING (s) is translated into
5713 int e;
5714 if (!isfinite (s))
5715 res = NaN;
5716 else if (s == 0)
5717 res = tiny;
5718 else
5719 {
5720 frexp (s, &e);
5721 e = e - prec;
5722 e = MAX_EXPR (e, emin);
5723 res = scalbn (1., e);
5724 }
5725 return res;
5726
5727 where prec is the precision of s, gfc_real_kinds[k].digits,
5728 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5729 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5730
5731 static void
gfc_conv_intrinsic_spacing(gfc_se * se,gfc_expr * expr)5732 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
5733 {
5734 tree arg, type, prec, emin, tiny, res, e;
5735 tree cond, nan, tmp, frexp, scalbn;
5736 int k;
5737 stmtblock_t block;
5738
5739 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
5740 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
5741 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
5742 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
5743
5744 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
5745 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
5746
5747 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5748 arg = gfc_evaluate_now (arg, &se->pre);
5749
5750 type = gfc_typenode_for_spec (&expr->ts);
5751 e = gfc_create_var (integer_type_node, NULL);
5752 res = gfc_create_var (type, NULL);
5753
5754
5755 /* Build the block for s /= 0. */
5756 gfc_start_block (&block);
5757 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
5758 gfc_build_addr_expr (NULL_TREE, e));
5759 gfc_add_expr_to_block (&block, tmp);
5760
5761 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
5762 prec);
5763 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
5764 integer_type_node, tmp, emin));
5765
5766 tmp = build_call_expr_loc (input_location, scalbn, 2,
5767 build_real_from_int_cst (type, integer_one_node), e);
5768 gfc_add_modify (&block, res, tmp);
5769
5770 /* Finish by building the IF statement for value zero. */
5771 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
5772 build_real_from_int_cst (type, integer_zero_node));
5773 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
5774 gfc_finish_block (&block));
5775
5776 /* And deal with infinities and NaNs. */
5777 cond = build_call_expr_loc (input_location,
5778 builtin_decl_explicit (BUILT_IN_ISFINITE),
5779 1, arg);
5780 nan = gfc_build_nan (type, "");
5781 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
5782
5783 gfc_add_expr_to_block (&se->pre, tmp);
5784 se->expr = res;
5785 }
5786
5787
5788 /* RRSPACING (s) is translated into
5789 int e;
5790 real x;
5791 x = fabs (s);
5792 if (isfinite (x))
5793 {
5794 if (x != 0)
5795 {
5796 frexp (s, &e);
5797 x = scalbn (x, precision - e);
5798 }
5799 }
5800 else
5801 x = NaN;
5802 return x;
5803
5804 where precision is gfc_real_kinds[k].digits. */
5805
5806 static void
gfc_conv_intrinsic_rrspacing(gfc_se * se,gfc_expr * expr)5807 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
5808 {
5809 tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
5810 int prec, k;
5811 stmtblock_t block;
5812
5813 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
5814 prec = gfc_real_kinds[k].digits;
5815
5816 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
5817 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
5818 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
5819
5820 type = gfc_typenode_for_spec (&expr->ts);
5821 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5822 arg = gfc_evaluate_now (arg, &se->pre);
5823
5824 e = gfc_create_var (integer_type_node, NULL);
5825 x = gfc_create_var (type, NULL);
5826 gfc_add_modify (&se->pre, x,
5827 build_call_expr_loc (input_location, fabs, 1, arg));
5828
5829
5830 gfc_start_block (&block);
5831 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
5832 gfc_build_addr_expr (NULL_TREE, e));
5833 gfc_add_expr_to_block (&block, tmp);
5834
5835 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
5836 build_int_cst (integer_type_node, prec), e);
5837 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
5838 gfc_add_modify (&block, x, tmp);
5839 stmt = gfc_finish_block (&block);
5840
5841 /* if (x != 0) */
5842 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
5843 build_real_from_int_cst (type, integer_zero_node));
5844 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
5845
5846 /* And deal with infinities and NaNs. */
5847 cond = build_call_expr_loc (input_location,
5848 builtin_decl_explicit (BUILT_IN_ISFINITE),
5849 1, x);
5850 nan = gfc_build_nan (type, "");
5851 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
5852
5853 gfc_add_expr_to_block (&se->pre, tmp);
5854 se->expr = fold_convert (type, x);
5855 }
5856
5857
5858 /* SCALE (s, i) is translated into scalbn (s, i). */
5859 static void
gfc_conv_intrinsic_scale(gfc_se * se,gfc_expr * expr)5860 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
5861 {
5862 tree args[2], type, scalbn;
5863
5864 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
5865
5866 type = gfc_typenode_for_spec (&expr->ts);
5867 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5868 se->expr = build_call_expr_loc (input_location, scalbn, 2,
5869 fold_convert (type, args[0]),
5870 fold_convert (integer_type_node, args[1]));
5871 se->expr = fold_convert (type, se->expr);
5872 }
5873
5874
5875 /* SET_EXPONENT (s, i) is translated into
5876 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
5877 static void
gfc_conv_intrinsic_set_exponent(gfc_se * se,gfc_expr * expr)5878 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
5879 {
5880 tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
5881
5882 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
5883 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
5884
5885 type = gfc_typenode_for_spec (&expr->ts);
5886 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5887 args[0] = gfc_evaluate_now (args[0], &se->pre);
5888
5889 tmp = gfc_create_var (integer_type_node, NULL);
5890 tmp = build_call_expr_loc (input_location, frexp, 2,
5891 fold_convert (type, args[0]),
5892 gfc_build_addr_expr (NULL_TREE, tmp));
5893 res = build_call_expr_loc (input_location, scalbn, 2, tmp,
5894 fold_convert (integer_type_node, args[1]));
5895 res = fold_convert (type, res);
5896
5897 /* Call to isfinite */
5898 cond = build_call_expr_loc (input_location,
5899 builtin_decl_explicit (BUILT_IN_ISFINITE),
5900 1, args[0]);
5901 nan = gfc_build_nan (type, "");
5902
5903 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
5904 res, nan);
5905 }
5906
5907
5908 static void
gfc_conv_intrinsic_size(gfc_se * se,gfc_expr * expr)5909 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
5910 {
5911 gfc_actual_arglist *actual;
5912 tree arg1;
5913 tree type;
5914 tree fncall0;
5915 tree fncall1;
5916 gfc_se argse;
5917
5918 gfc_init_se (&argse, NULL);
5919 actual = expr->value.function.actual;
5920
5921 if (actual->expr->ts.type == BT_CLASS)
5922 gfc_add_class_array_ref (actual->expr);
5923
5924 argse.data_not_needed = 1;
5925 if (gfc_is_class_array_function (actual->expr))
5926 {
5927 /* For functions that return a class array conv_expr_descriptor is not
5928 able to get the descriptor right. Therefore this special case. */
5929 gfc_conv_expr_reference (&argse, actual->expr);
5930 argse.expr = gfc_build_addr_expr (NULL_TREE,
5931 gfc_class_data_get (argse.expr));
5932 }
5933 else
5934 {
5935 argse.want_pointer = 1;
5936 gfc_conv_expr_descriptor (&argse, actual->expr);
5937 }
5938 gfc_add_block_to_block (&se->pre, &argse.pre);
5939 gfc_add_block_to_block (&se->post, &argse.post);
5940 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
5941
5942 /* Build the call to size0. */
5943 fncall0 = build_call_expr_loc (input_location,
5944 gfor_fndecl_size0, 1, arg1);
5945
5946 actual = actual->next;
5947
5948 if (actual->expr)
5949 {
5950 gfc_init_se (&argse, NULL);
5951 gfc_conv_expr_type (&argse, actual->expr,
5952 gfc_array_index_type);
5953 gfc_add_block_to_block (&se->pre, &argse.pre);
5954
5955 /* Unusually, for an intrinsic, size does not exclude
5956 an optional arg2, so we must test for it. */
5957 if (actual->expr->expr_type == EXPR_VARIABLE
5958 && actual->expr->symtree->n.sym->attr.dummy
5959 && actual->expr->symtree->n.sym->attr.optional)
5960 {
5961 tree tmp;
5962 /* Build the call to size1. */
5963 fncall1 = build_call_expr_loc (input_location,
5964 gfor_fndecl_size1, 2,
5965 arg1, argse.expr);
5966
5967 gfc_init_se (&argse, NULL);
5968 argse.want_pointer = 1;
5969 argse.data_not_needed = 1;
5970 gfc_conv_expr (&argse, actual->expr);
5971 gfc_add_block_to_block (&se->pre, &argse.pre);
5972 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5973 argse.expr, null_pointer_node);
5974 tmp = gfc_evaluate_now (tmp, &se->pre);
5975 se->expr = fold_build3_loc (input_location, COND_EXPR,
5976 pvoid_type_node, tmp, fncall1, fncall0);
5977 }
5978 else
5979 {
5980 se->expr = NULL_TREE;
5981 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
5982 gfc_array_index_type,
5983 argse.expr, gfc_index_one_node);
5984 }
5985 }
5986 else if (expr->value.function.actual->expr->rank == 1)
5987 {
5988 argse.expr = gfc_index_zero_node;
5989 se->expr = NULL_TREE;
5990 }
5991 else
5992 se->expr = fncall0;
5993
5994 if (se->expr == NULL_TREE)
5995 {
5996 tree ubound, lbound;
5997
5998 arg1 = build_fold_indirect_ref_loc (input_location,
5999 arg1);
6000 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
6001 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
6002 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
6003 gfc_array_index_type, ubound, lbound);
6004 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
6005 gfc_array_index_type,
6006 se->expr, gfc_index_one_node);
6007 se->expr = fold_build2_loc (input_location, MAX_EXPR,
6008 gfc_array_index_type, se->expr,
6009 gfc_index_zero_node);
6010 }
6011
6012 type = gfc_typenode_for_spec (&expr->ts);
6013 se->expr = convert (type, se->expr);
6014 }
6015
6016
6017 /* Helper function to compute the size of a character variable,
6018 excluding the terminating null characters. The result has
6019 gfc_array_index_type type. */
6020
6021 tree
size_of_string_in_bytes(int kind,tree string_length)6022 size_of_string_in_bytes (int kind, tree string_length)
6023 {
6024 tree bytesize;
6025 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
6026
6027 bytesize = build_int_cst (gfc_array_index_type,
6028 gfc_character_kinds[i].bit_size / 8);
6029
6030 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6031 bytesize,
6032 fold_convert (gfc_array_index_type, string_length));
6033 }
6034
6035
6036 static void
gfc_conv_intrinsic_sizeof(gfc_se * se,gfc_expr * expr)6037 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
6038 {
6039 gfc_expr *arg;
6040 gfc_se argse;
6041 tree source_bytes;
6042 tree tmp;
6043 tree lower;
6044 tree upper;
6045 tree byte_size;
6046 int n;
6047
6048 gfc_init_se (&argse, NULL);
6049 arg = expr->value.function.actual->expr;
6050
6051 if (arg->rank || arg->ts.type == BT_ASSUMED)
6052 gfc_conv_expr_descriptor (&argse, arg);
6053 else
6054 gfc_conv_expr_reference (&argse, arg);
6055
6056 if (arg->ts.type == BT_ASSUMED)
6057 {
6058 /* This only works if an array descriptor has been passed; thus, extract
6059 the size from the descriptor. */
6060 gcc_assert (TYPE_PRECISION (gfc_array_index_type)
6061 == TYPE_PRECISION (size_type_node));
6062 tmp = arg->symtree->n.sym->backend_decl;
6063 tmp = DECL_LANG_SPECIFIC (tmp)
6064 && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
6065 ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
6066 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
6067 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6068 tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp));
6069 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp,
6070 build_int_cst (TREE_TYPE (tmp),
6071 GFC_DTYPE_SIZE_SHIFT));
6072 byte_size = fold_convert (gfc_array_index_type, tmp);
6073 }
6074 else if (arg->ts.type == BT_CLASS)
6075 {
6076 /* Conv_expr_descriptor returns a component_ref to _data component of the
6077 class object. The class object may be a non-pointer object, e.g.
6078 located on the stack, or a memory location pointed to, e.g. a
6079 parameter, i.e., an indirect_ref. */
6080 if (arg->rank < 0
6081 || (arg->rank > 0 && !VAR_P (argse.expr)
6082 && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
6083 && GFC_DECL_CLASS (TREE_OPERAND (
6084 TREE_OPERAND (argse.expr, 0), 0)))
6085 || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
6086 byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
6087 else if (arg->rank > 0
6088 || (arg->rank == 0
6089 && arg->ref && arg->ref->type == REF_COMPONENT))
6090 /* The scalarizer added an additional temp. To get the class' vptr
6091 one has to look at the original backend_decl. */
6092 byte_size = gfc_class_vtab_size_get (
6093 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
6094 else
6095 byte_size = gfc_class_vtab_size_get (argse.expr);
6096 }
6097 else
6098 {
6099 if (arg->ts.type == BT_CHARACTER)
6100 byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
6101 else
6102 {
6103 if (arg->rank == 0)
6104 byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6105 argse.expr));
6106 else
6107 byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
6108 byte_size = fold_convert (gfc_array_index_type,
6109 size_in_bytes (byte_size));
6110 }
6111 }
6112
6113 if (arg->rank == 0)
6114 se->expr = byte_size;
6115 else
6116 {
6117 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
6118 gfc_add_modify (&argse.pre, source_bytes, byte_size);
6119
6120 if (arg->rank == -1)
6121 {
6122 tree cond, loop_var, exit_label;
6123 stmtblock_t body;
6124
6125 tmp = fold_convert (gfc_array_index_type,
6126 gfc_conv_descriptor_rank (argse.expr));
6127 loop_var = gfc_create_var (gfc_array_index_type, "i");
6128 gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
6129 exit_label = gfc_build_label_decl (NULL_TREE);
6130
6131 /* Create loop:
6132 for (;;)
6133 {
6134 if (i >= rank)
6135 goto exit;
6136 source_bytes = source_bytes * array.dim[i].extent;
6137 i = i + 1;
6138 }
6139 exit: */
6140 gfc_start_block (&body);
6141 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6142 loop_var, tmp);
6143 tmp = build1_v (GOTO_EXPR, exit_label);
6144 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
6145 cond, tmp, build_empty_stmt (input_location));
6146 gfc_add_expr_to_block (&body, tmp);
6147
6148 lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
6149 upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
6150 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
6151 tmp = fold_build2_loc (input_location, MULT_EXPR,
6152 gfc_array_index_type, tmp, source_bytes);
6153 gfc_add_modify (&body, source_bytes, tmp);
6154
6155 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6156 gfc_array_index_type, loop_var,
6157 gfc_index_one_node);
6158 gfc_add_modify_loc (input_location, &body, loop_var, tmp);
6159
6160 tmp = gfc_finish_block (&body);
6161
6162 tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
6163 tmp);
6164 gfc_add_expr_to_block (&argse.pre, tmp);
6165
6166 tmp = build1_v (LABEL_EXPR, exit_label);
6167 gfc_add_expr_to_block (&argse.pre, tmp);
6168 }
6169 else
6170 {
6171 /* Obtain the size of the array in bytes. */
6172 for (n = 0; n < arg->rank; n++)
6173 {
6174 tree idx;
6175 idx = gfc_rank_cst[n];
6176 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
6177 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
6178 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
6179 tmp = fold_build2_loc (input_location, MULT_EXPR,
6180 gfc_array_index_type, tmp, source_bytes);
6181 gfc_add_modify (&argse.pre, source_bytes, tmp);
6182 }
6183 }
6184 se->expr = source_bytes;
6185 }
6186
6187 gfc_add_block_to_block (&se->pre, &argse.pre);
6188 }
6189
6190
6191 static void
gfc_conv_intrinsic_storage_size(gfc_se * se,gfc_expr * expr)6192 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
6193 {
6194 gfc_expr *arg;
6195 gfc_se argse;
6196 tree type, result_type, tmp;
6197
6198 arg = expr->value.function.actual->expr;
6199
6200 gfc_init_se (&argse, NULL);
6201 result_type = gfc_get_int_type (expr->ts.kind);
6202
6203 if (arg->rank == 0)
6204 {
6205 if (arg->ts.type == BT_CLASS)
6206 {
6207 gfc_add_vptr_component (arg);
6208 gfc_add_size_component (arg);
6209 gfc_conv_expr (&argse, arg);
6210 tmp = fold_convert (result_type, argse.expr);
6211 goto done;
6212 }
6213
6214 gfc_conv_expr_reference (&argse, arg);
6215 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6216 argse.expr));
6217 }
6218 else
6219 {
6220 argse.want_pointer = 0;
6221 gfc_conv_expr_descriptor (&argse, arg);
6222 if (arg->ts.type == BT_CLASS)
6223 {
6224 if (arg->rank > 0)
6225 tmp = gfc_class_vtab_size_get (
6226 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
6227 else
6228 tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
6229 tmp = fold_convert (result_type, tmp);
6230 goto done;
6231 }
6232 type = gfc_get_element_type (TREE_TYPE (argse.expr));
6233 }
6234
6235 /* Obtain the argument's word length. */
6236 if (arg->ts.type == BT_CHARACTER)
6237 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
6238 else
6239 tmp = size_in_bytes (type);
6240 tmp = fold_convert (result_type, tmp);
6241
6242 done:
6243 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
6244 build_int_cst (result_type, BITS_PER_UNIT));
6245 gfc_add_block_to_block (&se->pre, &argse.pre);
6246 }
6247
6248
6249 /* Intrinsic string comparison functions. */
6250
6251 static void
gfc_conv_intrinsic_strcmp(gfc_se * se,gfc_expr * expr,enum tree_code op)6252 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6253 {
6254 tree args[4];
6255
6256 gfc_conv_intrinsic_function_args (se, expr, args, 4);
6257
6258 se->expr
6259 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
6260 expr->value.function.actual->expr->ts.kind,
6261 op);
6262 se->expr = fold_build2_loc (input_location, op,
6263 gfc_typenode_for_spec (&expr->ts), se->expr,
6264 build_int_cst (TREE_TYPE (se->expr), 0));
6265 }
6266
6267 /* Generate a call to the adjustl/adjustr library function. */
6268 static void
gfc_conv_intrinsic_adjust(gfc_se * se,gfc_expr * expr,tree fndecl)6269 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
6270 {
6271 tree args[3];
6272 tree len;
6273 tree type;
6274 tree var;
6275 tree tmp;
6276
6277 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
6278 len = args[1];
6279
6280 type = TREE_TYPE (args[2]);
6281 var = gfc_conv_string_tmp (se, type, len);
6282 args[0] = var;
6283
6284 tmp = build_call_expr_loc (input_location,
6285 fndecl, 3, args[0], args[1], args[2]);
6286 gfc_add_expr_to_block (&se->pre, tmp);
6287 se->expr = var;
6288 se->string_length = len;
6289 }
6290
6291
6292 /* Generate code for the TRANSFER intrinsic:
6293 For scalar results:
6294 DEST = TRANSFER (SOURCE, MOLD)
6295 where:
6296 typeof<DEST> = typeof<MOLD>
6297 and:
6298 MOLD is scalar.
6299
6300 For array results:
6301 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6302 where:
6303 typeof<DEST> = typeof<MOLD>
6304 and:
6305 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6306 sizeof (DEST(0) * SIZE). */
6307 static void
gfc_conv_intrinsic_transfer(gfc_se * se,gfc_expr * expr)6308 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
6309 {
6310 tree tmp;
6311 tree tmpdecl;
6312 tree ptr;
6313 tree extent;
6314 tree source;
6315 tree source_type;
6316 tree source_bytes;
6317 tree mold_type;
6318 tree dest_word_len;
6319 tree size_words;
6320 tree size_bytes;
6321 tree upper;
6322 tree lower;
6323 tree stmt;
6324 gfc_actual_arglist *arg;
6325 gfc_se argse;
6326 gfc_array_info *info;
6327 stmtblock_t block;
6328 int n;
6329 bool scalar_mold;
6330 gfc_expr *source_expr, *mold_expr;
6331
6332 info = NULL;
6333 if (se->loop)
6334 info = &se->ss->info->data.array;
6335
6336 /* Convert SOURCE. The output from this stage is:-
6337 source_bytes = length of the source in bytes
6338 source = pointer to the source data. */
6339 arg = expr->value.function.actual;
6340 source_expr = arg->expr;
6341
6342 /* Ensure double transfer through LOGICAL preserves all
6343 the needed bits. */
6344 if (arg->expr->expr_type == EXPR_FUNCTION
6345 && arg->expr->value.function.esym == NULL
6346 && arg->expr->value.function.isym != NULL
6347 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
6348 && arg->expr->ts.type == BT_LOGICAL
6349 && expr->ts.type != arg->expr->ts.type)
6350 arg->expr->value.function.name = "__transfer_in_transfer";
6351
6352 gfc_init_se (&argse, NULL);
6353
6354 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
6355
6356 /* Obtain the pointer to source and the length of source in bytes. */
6357 if (arg->expr->rank == 0)
6358 {
6359 gfc_conv_expr_reference (&argse, arg->expr);
6360 if (arg->expr->ts.type == BT_CLASS)
6361 source = gfc_class_data_get (argse.expr);
6362 else
6363 source = argse.expr;
6364
6365 /* Obtain the source word length. */
6366 switch (arg->expr->ts.type)
6367 {
6368 case BT_CHARACTER:
6369 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
6370 argse.string_length);
6371 break;
6372 case BT_CLASS:
6373 tmp = gfc_class_vtab_size_get (argse.expr);
6374 break;
6375 default:
6376 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6377 source));
6378 tmp = fold_convert (gfc_array_index_type,
6379 size_in_bytes (source_type));
6380 break;
6381 }
6382 }
6383 else
6384 {
6385 argse.want_pointer = 0;
6386 gfc_conv_expr_descriptor (&argse, arg->expr);
6387 source = gfc_conv_descriptor_data_get (argse.expr);
6388 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
6389
6390 /* Repack the source if not simply contiguous. */
6391 if (!gfc_is_simply_contiguous (arg->expr, false, true))
6392 {
6393 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
6394
6395 if (warn_array_temporaries)
6396 gfc_warning (OPT_Warray_temporaries,
6397 "Creating array temporary at %L", &expr->where);
6398
6399 source = build_call_expr_loc (input_location,
6400 gfor_fndecl_in_pack, 1, tmp);
6401 source = gfc_evaluate_now (source, &argse.pre);
6402
6403 /* Free the temporary. */
6404 gfc_start_block (&block);
6405 tmp = gfc_call_free (source);
6406 gfc_add_expr_to_block (&block, tmp);
6407 stmt = gfc_finish_block (&block);
6408
6409 /* Clean up if it was repacked. */
6410 gfc_init_block (&block);
6411 tmp = gfc_conv_array_data (argse.expr);
6412 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6413 source, tmp);
6414 tmp = build3_v (COND_EXPR, tmp, stmt,
6415 build_empty_stmt (input_location));
6416 gfc_add_expr_to_block (&block, tmp);
6417 gfc_add_block_to_block (&block, &se->post);
6418 gfc_init_block (&se->post);
6419 gfc_add_block_to_block (&se->post, &block);
6420 }
6421
6422 /* Obtain the source word length. */
6423 if (arg->expr->ts.type == BT_CHARACTER)
6424 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
6425 argse.string_length);
6426 else
6427 tmp = fold_convert (gfc_array_index_type,
6428 size_in_bytes (source_type));
6429
6430 /* Obtain the size of the array in bytes. */
6431 extent = gfc_create_var (gfc_array_index_type, NULL);
6432 for (n = 0; n < arg->expr->rank; n++)
6433 {
6434 tree idx;
6435 idx = gfc_rank_cst[n];
6436 gfc_add_modify (&argse.pre, source_bytes, tmp);
6437 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
6438 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
6439 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6440 gfc_array_index_type, upper, lower);
6441 gfc_add_modify (&argse.pre, extent, tmp);
6442 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6443 gfc_array_index_type, extent,
6444 gfc_index_one_node);
6445 tmp = fold_build2_loc (input_location, MULT_EXPR,
6446 gfc_array_index_type, tmp, source_bytes);
6447 }
6448 }
6449
6450 gfc_add_modify (&argse.pre, source_bytes, tmp);
6451 gfc_add_block_to_block (&se->pre, &argse.pre);
6452 gfc_add_block_to_block (&se->post, &argse.post);
6453
6454 /* Now convert MOLD. The outputs are:
6455 mold_type = the TREE type of MOLD
6456 dest_word_len = destination word length in bytes. */
6457 arg = arg->next;
6458 mold_expr = arg->expr;
6459
6460 gfc_init_se (&argse, NULL);
6461
6462 scalar_mold = arg->expr->rank == 0;
6463
6464 if (arg->expr->rank == 0)
6465 {
6466 gfc_conv_expr_reference (&argse, arg->expr);
6467 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6468 argse.expr));
6469 }
6470 else
6471 {
6472 gfc_init_se (&argse, NULL);
6473 argse.want_pointer = 0;
6474 gfc_conv_expr_descriptor (&argse, arg->expr);
6475 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
6476 }
6477
6478 gfc_add_block_to_block (&se->pre, &argse.pre);
6479 gfc_add_block_to_block (&se->post, &argse.post);
6480
6481 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
6482 {
6483 /* If this TRANSFER is nested in another TRANSFER, use a type
6484 that preserves all bits. */
6485 if (arg->expr->ts.type == BT_LOGICAL)
6486 mold_type = gfc_get_int_type (arg->expr->ts.kind);
6487 }
6488
6489 /* Obtain the destination word length. */
6490 switch (arg->expr->ts.type)
6491 {
6492 case BT_CHARACTER:
6493 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
6494 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
6495 break;
6496 case BT_CLASS:
6497 tmp = gfc_class_vtab_size_get (argse.expr);
6498 break;
6499 default:
6500 tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
6501 break;
6502 }
6503 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
6504 gfc_add_modify (&se->pre, dest_word_len, tmp);
6505
6506 /* Finally convert SIZE, if it is present. */
6507 arg = arg->next;
6508 size_words = gfc_create_var (gfc_array_index_type, NULL);
6509
6510 if (arg->expr)
6511 {
6512 gfc_init_se (&argse, NULL);
6513 gfc_conv_expr_reference (&argse, arg->expr);
6514 tmp = convert (gfc_array_index_type,
6515 build_fold_indirect_ref_loc (input_location,
6516 argse.expr));
6517 gfc_add_block_to_block (&se->pre, &argse.pre);
6518 gfc_add_block_to_block (&se->post, &argse.post);
6519 }
6520 else
6521 tmp = NULL_TREE;
6522
6523 /* Separate array and scalar results. */
6524 if (scalar_mold && tmp == NULL_TREE)
6525 goto scalar_transfer;
6526
6527 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
6528 if (tmp != NULL_TREE)
6529 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6530 tmp, dest_word_len);
6531 else
6532 tmp = source_bytes;
6533
6534 gfc_add_modify (&se->pre, size_bytes, tmp);
6535 gfc_add_modify (&se->pre, size_words,
6536 fold_build2_loc (input_location, CEIL_DIV_EXPR,
6537 gfc_array_index_type,
6538 size_bytes, dest_word_len));
6539
6540 /* Evaluate the bounds of the result. If the loop range exists, we have
6541 to check if it is too large. If so, we modify loop->to be consistent
6542 with min(size, size(source)). Otherwise, size is made consistent with
6543 the loop range, so that the right number of bytes is transferred.*/
6544 n = se->loop->order[0];
6545 if (se->loop->to[n] != NULL_TREE)
6546 {
6547 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6548 se->loop->to[n], se->loop->from[n]);
6549 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6550 tmp, gfc_index_one_node);
6551 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
6552 tmp, size_words);
6553 gfc_add_modify (&se->pre, size_words, tmp);
6554 gfc_add_modify (&se->pre, size_bytes,
6555 fold_build2_loc (input_location, MULT_EXPR,
6556 gfc_array_index_type,
6557 size_words, dest_word_len));
6558 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6559 size_words, se->loop->from[n]);
6560 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6561 upper, gfc_index_one_node);
6562 }
6563 else
6564 {
6565 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6566 size_words, gfc_index_one_node);
6567 se->loop->from[n] = gfc_index_zero_node;
6568 }
6569
6570 se->loop->to[n] = upper;
6571
6572 /* Build a destination descriptor, using the pointer, source, as the
6573 data field. */
6574 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
6575 NULL_TREE, false, true, false, &expr->where);
6576
6577 /* Cast the pointer to the result. */
6578 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6579 tmp = fold_convert (pvoid_type_node, tmp);
6580
6581 /* Use memcpy to do the transfer. */
6582 tmp
6583 = build_call_expr_loc (input_location,
6584 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
6585 fold_convert (pvoid_type_node, source),
6586 fold_convert (size_type_node,
6587 fold_build2_loc (input_location,
6588 MIN_EXPR,
6589 gfc_array_index_type,
6590 size_bytes,
6591 source_bytes)));
6592 gfc_add_expr_to_block (&se->pre, tmp);
6593
6594 se->expr = info->descriptor;
6595 if (expr->ts.type == BT_CHARACTER)
6596 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
6597
6598 return;
6599
6600 /* Deal with scalar results. */
6601 scalar_transfer:
6602 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
6603 dest_word_len, source_bytes);
6604 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6605 extent, gfc_index_zero_node);
6606
6607 if (expr->ts.type == BT_CHARACTER)
6608 {
6609 tree direct, indirect, free;
6610
6611 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
6612 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
6613 "transfer");
6614
6615 /* If source is longer than the destination, use a pointer to
6616 the source directly. */
6617 gfc_init_block (&block);
6618 gfc_add_modify (&block, tmpdecl, ptr);
6619 direct = gfc_finish_block (&block);
6620
6621 /* Otherwise, allocate a string with the length of the destination
6622 and copy the source into it. */
6623 gfc_init_block (&block);
6624 tmp = gfc_get_pchar_type (expr->ts.kind);
6625 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
6626 gfc_add_modify (&block, tmpdecl,
6627 fold_convert (TREE_TYPE (ptr), tmp));
6628 tmp = build_call_expr_loc (input_location,
6629 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
6630 fold_convert (pvoid_type_node, tmpdecl),
6631 fold_convert (pvoid_type_node, ptr),
6632 fold_convert (size_type_node, extent));
6633 gfc_add_expr_to_block (&block, tmp);
6634 indirect = gfc_finish_block (&block);
6635
6636 /* Wrap it up with the condition. */
6637 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
6638 dest_word_len, source_bytes);
6639 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
6640 gfc_add_expr_to_block (&se->pre, tmp);
6641
6642 /* Free the temporary string, if necessary. */
6643 free = gfc_call_free (tmpdecl);
6644 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
6645 dest_word_len, source_bytes);
6646 tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
6647 gfc_add_expr_to_block (&se->post, tmp);
6648
6649 se->expr = tmpdecl;
6650 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
6651 }
6652 else
6653 {
6654 tmpdecl = gfc_create_var (mold_type, "transfer");
6655
6656 ptr = convert (build_pointer_type (mold_type), source);
6657
6658 /* For CLASS results, allocate the needed memory first. */
6659 if (mold_expr->ts.type == BT_CLASS)
6660 {
6661 tree cdata;
6662 cdata = gfc_class_data_get (tmpdecl);
6663 tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
6664 gfc_add_modify (&se->pre, cdata, tmp);
6665 }
6666
6667 /* Use memcpy to do the transfer. */
6668 if (mold_expr->ts.type == BT_CLASS)
6669 tmp = gfc_class_data_get (tmpdecl);
6670 else
6671 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
6672
6673 tmp = build_call_expr_loc (input_location,
6674 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
6675 fold_convert (pvoid_type_node, tmp),
6676 fold_convert (pvoid_type_node, ptr),
6677 fold_convert (size_type_node, extent));
6678 gfc_add_expr_to_block (&se->pre, tmp);
6679
6680 /* For CLASS results, set the _vptr. */
6681 if (mold_expr->ts.type == BT_CLASS)
6682 {
6683 tree vptr;
6684 gfc_symbol *vtab;
6685 vptr = gfc_class_vptr_get (tmpdecl);
6686 vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
6687 gcc_assert (vtab);
6688 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
6689 gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
6690 }
6691
6692 se->expr = tmpdecl;
6693 }
6694 }
6695
6696
6697 /* Generate code for the ALLOCATED intrinsic.
6698 Generate inline code that directly check the address of the argument. */
6699
6700 static void
gfc_conv_allocated(gfc_se * se,gfc_expr * expr)6701 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
6702 {
6703 gfc_actual_arglist *arg1;
6704 gfc_se arg1se;
6705 tree tmp;
6706
6707 gfc_init_se (&arg1se, NULL);
6708 arg1 = expr->value.function.actual;
6709
6710 if (arg1->expr->ts.type == BT_CLASS)
6711 {
6712 /* Make sure that class array expressions have both a _data
6713 component reference and an array reference.... */
6714 if (CLASS_DATA (arg1->expr)->attr.dimension)
6715 gfc_add_class_array_ref (arg1->expr);
6716 /* .... whilst scalars only need the _data component. */
6717 else
6718 gfc_add_data_component (arg1->expr);
6719 }
6720
6721 if (arg1->expr->rank == 0)
6722 {
6723 /* Allocatable scalar. */
6724 arg1se.want_pointer = 1;
6725 gfc_conv_expr (&arg1se, arg1->expr);
6726 tmp = arg1se.expr;
6727 }
6728 else
6729 {
6730 /* Allocatable array. */
6731 arg1se.descriptor_only = 1;
6732 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
6733 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
6734 }
6735
6736 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
6737 fold_convert (TREE_TYPE (tmp), null_pointer_node));
6738 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6739 }
6740
6741
6742 /* Generate code for the ASSOCIATED intrinsic.
6743 If both POINTER and TARGET are arrays, generate a call to library function
6744 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6745 In other cases, generate inline code that directly compare the address of
6746 POINTER with the address of TARGET. */
6747
6748 static void
gfc_conv_associated(gfc_se * se,gfc_expr * expr)6749 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
6750 {
6751 gfc_actual_arglist *arg1;
6752 gfc_actual_arglist *arg2;
6753 gfc_se arg1se;
6754 gfc_se arg2se;
6755 tree tmp2;
6756 tree tmp;
6757 tree nonzero_charlen;
6758 tree nonzero_arraylen;
6759 gfc_ss *ss;
6760 bool scalar;
6761
6762 gfc_init_se (&arg1se, NULL);
6763 gfc_init_se (&arg2se, NULL);
6764 arg1 = expr->value.function.actual;
6765 arg2 = arg1->next;
6766
6767 /* Check whether the expression is a scalar or not; we cannot use
6768 arg1->expr->rank as it can be nonzero for proc pointers. */
6769 ss = gfc_walk_expr (arg1->expr);
6770 scalar = ss == gfc_ss_terminator;
6771 if (!scalar)
6772 gfc_free_ss_chain (ss);
6773
6774 if (!arg2->expr)
6775 {
6776 /* No optional target. */
6777 if (scalar)
6778 {
6779 /* A pointer to a scalar. */
6780 arg1se.want_pointer = 1;
6781 gfc_conv_expr (&arg1se, arg1->expr);
6782 if (arg1->expr->symtree->n.sym->attr.proc_pointer
6783 && arg1->expr->symtree->n.sym->attr.dummy)
6784 arg1se.expr = build_fold_indirect_ref_loc (input_location,
6785 arg1se.expr);
6786 if (arg1->expr->ts.type == BT_CLASS)
6787 {
6788 tmp2 = gfc_class_data_get (arg1se.expr);
6789 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6790 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6791 }
6792 else
6793 tmp2 = arg1se.expr;
6794 }
6795 else
6796 {
6797 /* A pointer to an array. */
6798 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
6799 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
6800 }
6801 gfc_add_block_to_block (&se->pre, &arg1se.pre);
6802 gfc_add_block_to_block (&se->post, &arg1se.post);
6803 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
6804 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
6805 se->expr = tmp;
6806 }
6807 else
6808 {
6809 /* An optional target. */
6810 if (arg2->expr->ts.type == BT_CLASS)
6811 gfc_add_data_component (arg2->expr);
6812
6813 nonzero_charlen = NULL_TREE;
6814 if (arg1->expr->ts.type == BT_CHARACTER)
6815 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
6816 boolean_type_node,
6817 arg1->expr->ts.u.cl->backend_decl,
6818 integer_zero_node);
6819 if (scalar)
6820 {
6821 /* A pointer to a scalar. */
6822 arg1se.want_pointer = 1;
6823 gfc_conv_expr (&arg1se, arg1->expr);
6824 if (arg1->expr->symtree->n.sym->attr.proc_pointer
6825 && arg1->expr->symtree->n.sym->attr.dummy)
6826 arg1se.expr = build_fold_indirect_ref_loc (input_location,
6827 arg1se.expr);
6828 if (arg1->expr->ts.type == BT_CLASS)
6829 arg1se.expr = gfc_class_data_get (arg1se.expr);
6830
6831 arg2se.want_pointer = 1;
6832 gfc_conv_expr (&arg2se, arg2->expr);
6833 if (arg2->expr->symtree->n.sym->attr.proc_pointer
6834 && arg2->expr->symtree->n.sym->attr.dummy)
6835 arg2se.expr = build_fold_indirect_ref_loc (input_location,
6836 arg2se.expr);
6837 gfc_add_block_to_block (&se->pre, &arg1se.pre);
6838 gfc_add_block_to_block (&se->post, &arg1se.post);
6839 gfc_add_block_to_block (&se->pre, &arg2se.pre);
6840 gfc_add_block_to_block (&se->post, &arg2se.post);
6841 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6842 arg1se.expr, arg2se.expr);
6843 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6844 arg1se.expr, null_pointer_node);
6845 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6846 boolean_type_node, tmp, tmp2);
6847 }
6848 else
6849 {
6850 /* An array pointer of zero length is not associated if target is
6851 present. */
6852 arg1se.descriptor_only = 1;
6853 gfc_conv_expr_lhs (&arg1se, arg1->expr);
6854 if (arg1->expr->rank == -1)
6855 {
6856 tmp = gfc_conv_descriptor_rank (arg1se.expr);
6857 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6858 TREE_TYPE (tmp), tmp, gfc_index_one_node);
6859 }
6860 else
6861 tmp = gfc_rank_cst[arg1->expr->rank - 1];
6862 tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
6863 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
6864 boolean_type_node, tmp,
6865 build_int_cst (TREE_TYPE (tmp), 0));
6866
6867 /* A pointer to an array, call library function _gfor_associated. */
6868 arg1se.want_pointer = 1;
6869 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
6870
6871 arg2se.want_pointer = 1;
6872 gfc_conv_expr_descriptor (&arg2se, arg2->expr);
6873 gfc_add_block_to_block (&se->pre, &arg2se.pre);
6874 gfc_add_block_to_block (&se->post, &arg2se.post);
6875 se->expr = build_call_expr_loc (input_location,
6876 gfor_fndecl_associated, 2,
6877 arg1se.expr, arg2se.expr);
6878 se->expr = convert (boolean_type_node, se->expr);
6879 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6880 boolean_type_node, se->expr,
6881 nonzero_arraylen);
6882 }
6883
6884 /* If target is present zero character length pointers cannot
6885 be associated. */
6886 if (nonzero_charlen != NULL_TREE)
6887 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6888 boolean_type_node,
6889 se->expr, nonzero_charlen);
6890 }
6891
6892 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
6893 }
6894
6895
6896 /* Generate code for the SAME_TYPE_AS intrinsic.
6897 Generate inline code that directly checks the vindices. */
6898
6899 static void
gfc_conv_same_type_as(gfc_se * se,gfc_expr * expr)6900 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
6901 {
6902 gfc_expr *a, *b;
6903 gfc_se se1, se2;
6904 tree tmp;
6905 tree conda = NULL_TREE, condb = NULL_TREE;
6906
6907 gfc_init_se (&se1, NULL);
6908 gfc_init_se (&se2, NULL);
6909
6910 a = expr->value.function.actual->expr;
6911 b = expr->value.function.actual->next->expr;
6912
6913 if (UNLIMITED_POLY (a))
6914 {
6915 tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
6916 conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6917 tmp, build_int_cst (TREE_TYPE (tmp), 0));
6918 }
6919
6920 if (UNLIMITED_POLY (b))
6921 {
6922 tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
6923 condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6924 tmp, build_int_cst (TREE_TYPE (tmp), 0));
6925 }
6926
6927 if (a->ts.type == BT_CLASS)
6928 {
6929 gfc_add_vptr_component (a);
6930 gfc_add_hash_component (a);
6931 }
6932 else if (a->ts.type == BT_DERIVED)
6933 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
6934 a->ts.u.derived->hash_value);
6935
6936 if (b->ts.type == BT_CLASS)
6937 {
6938 gfc_add_vptr_component (b);
6939 gfc_add_hash_component (b);
6940 }
6941 else if (b->ts.type == BT_DERIVED)
6942 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
6943 b->ts.u.derived->hash_value);
6944
6945 gfc_conv_expr (&se1, a);
6946 gfc_conv_expr (&se2, b);
6947
6948 tmp = fold_build2_loc (input_location, EQ_EXPR,
6949 boolean_type_node, se1.expr,
6950 fold_convert (TREE_TYPE (se1.expr), se2.expr));
6951
6952 if (conda)
6953 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6954 boolean_type_node, conda, tmp);
6955
6956 if (condb)
6957 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6958 boolean_type_node, condb, tmp);
6959
6960 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6961 }
6962
6963
6964 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6965
6966 static void
gfc_conv_intrinsic_sc_kind(gfc_se * se,gfc_expr * expr)6967 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
6968 {
6969 tree args[2];
6970
6971 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6972 se->expr = build_call_expr_loc (input_location,
6973 gfor_fndecl_sc_kind, 2, args[0], args[1]);
6974 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
6975 }
6976
6977
6978 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6979
6980 static void
gfc_conv_intrinsic_si_kind(gfc_se * se,gfc_expr * expr)6981 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
6982 {
6983 tree arg, type;
6984
6985 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6986
6987 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6988 type = gfc_get_int_type (4);
6989 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
6990
6991 /* Convert it to the required type. */
6992 type = gfc_typenode_for_spec (&expr->ts);
6993 se->expr = build_call_expr_loc (input_location,
6994 gfor_fndecl_si_kind, 1, arg);
6995 se->expr = fold_convert (type, se->expr);
6996 }
6997
6998
6999 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7000
7001 static void
gfc_conv_intrinsic_sr_kind(gfc_se * se,gfc_expr * expr)7002 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
7003 {
7004 gfc_actual_arglist *actual;
7005 tree type;
7006 gfc_se argse;
7007 vec<tree, va_gc> *args = NULL;
7008
7009 for (actual = expr->value.function.actual; actual; actual = actual->next)
7010 {
7011 gfc_init_se (&argse, se);
7012
7013 /* Pass a NULL pointer for an absent arg. */
7014 if (actual->expr == NULL)
7015 argse.expr = null_pointer_node;
7016 else
7017 {
7018 gfc_typespec ts;
7019 gfc_clear_ts (&ts);
7020
7021 if (actual->expr->ts.kind != gfc_c_int_kind)
7022 {
7023 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7024 ts.type = BT_INTEGER;
7025 ts.kind = gfc_c_int_kind;
7026 gfc_convert_type (actual->expr, &ts, 2);
7027 }
7028 gfc_conv_expr_reference (&argse, actual->expr);
7029 }
7030
7031 gfc_add_block_to_block (&se->pre, &argse.pre);
7032 gfc_add_block_to_block (&se->post, &argse.post);
7033 vec_safe_push (args, argse.expr);
7034 }
7035
7036 /* Convert it to the required type. */
7037 type = gfc_typenode_for_spec (&expr->ts);
7038 se->expr = build_call_expr_loc_vec (input_location,
7039 gfor_fndecl_sr_kind, args);
7040 se->expr = fold_convert (type, se->expr);
7041 }
7042
7043
7044 /* Generate code for TRIM (A) intrinsic function. */
7045
7046 static void
gfc_conv_intrinsic_trim(gfc_se * se,gfc_expr * expr)7047 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
7048 {
7049 tree var;
7050 tree len;
7051 tree addr;
7052 tree tmp;
7053 tree cond;
7054 tree fndecl;
7055 tree function;
7056 tree *args;
7057 unsigned int num_args;
7058
7059 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
7060 args = XALLOCAVEC (tree, num_args);
7061
7062 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
7063 addr = gfc_build_addr_expr (ppvoid_type_node, var);
7064 len = gfc_create_var (gfc_charlen_type_node, "len");
7065
7066 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
7067 args[0] = gfc_build_addr_expr (NULL_TREE, len);
7068 args[1] = addr;
7069
7070 if (expr->ts.kind == 1)
7071 function = gfor_fndecl_string_trim;
7072 else if (expr->ts.kind == 4)
7073 function = gfor_fndecl_string_trim_char4;
7074 else
7075 gcc_unreachable ();
7076
7077 fndecl = build_addr (function);
7078 tmp = build_call_array_loc (input_location,
7079 TREE_TYPE (TREE_TYPE (function)), fndecl,
7080 num_args, args);
7081 gfc_add_expr_to_block (&se->pre, tmp);
7082
7083 /* Free the temporary afterwards, if necessary. */
7084 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7085 len, build_int_cst (TREE_TYPE (len), 0));
7086 tmp = gfc_call_free (var);
7087 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
7088 gfc_add_expr_to_block (&se->post, tmp);
7089
7090 se->expr = var;
7091 se->string_length = len;
7092 }
7093
7094
7095 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7096
7097 static void
gfc_conv_intrinsic_repeat(gfc_se * se,gfc_expr * expr)7098 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
7099 {
7100 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
7101 tree type, cond, tmp, count, exit_label, n, max, largest;
7102 tree size;
7103 stmtblock_t block, body;
7104 int i;
7105
7106 /* We store in charsize the size of a character. */
7107 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
7108 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
7109
7110 /* Get the arguments. */
7111 gfc_conv_intrinsic_function_args (se, expr, args, 3);
7112 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
7113 src = args[1];
7114 ncopies = gfc_evaluate_now (args[2], &se->pre);
7115 ncopies_type = TREE_TYPE (ncopies);
7116
7117 /* Check that NCOPIES is not negative. */
7118 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
7119 build_int_cst (ncopies_type, 0));
7120 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
7121 "Argument NCOPIES of REPEAT intrinsic is negative "
7122 "(its value is %ld)",
7123 fold_convert (long_integer_type_node, ncopies));
7124
7125 /* If the source length is zero, any non negative value of NCOPIES
7126 is valid, and nothing happens. */
7127 n = gfc_create_var (ncopies_type, "ncopies");
7128 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
7129 build_int_cst (size_type_node, 0));
7130 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
7131 build_int_cst (ncopies_type, 0), ncopies);
7132 gfc_add_modify (&se->pre, n, tmp);
7133 ncopies = n;
7134
7135 /* Check that ncopies is not too large: ncopies should be less than
7136 (or equal to) MAX / slen, where MAX is the maximal integer of
7137 the gfc_charlen_type_node type. If slen == 0, we need a special
7138 case to avoid the division by zero. */
7139 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
7140 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
7141 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
7142 fold_convert (size_type_node, max), slen);
7143 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
7144 ? size_type_node : ncopies_type;
7145 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7146 fold_convert (largest, ncopies),
7147 fold_convert (largest, max));
7148 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
7149 build_int_cst (size_type_node, 0));
7150 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
7151 boolean_false_node, cond);
7152 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
7153 "Argument NCOPIES of REPEAT intrinsic is too large");
7154
7155 /* Compute the destination length. */
7156 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7157 fold_convert (gfc_charlen_type_node, slen),
7158 fold_convert (gfc_charlen_type_node, ncopies));
7159 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
7160 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
7161
7162 /* Generate the code to do the repeat operation:
7163 for (i = 0; i < ncopies; i++)
7164 memmove (dest + (i * slen * size), src, slen*size); */
7165 gfc_start_block (&block);
7166 count = gfc_create_var (ncopies_type, "count");
7167 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
7168 exit_label = gfc_build_label_decl (NULL_TREE);
7169
7170 /* Start the loop body. */
7171 gfc_start_block (&body);
7172
7173 /* Exit the loop if count >= ncopies. */
7174 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
7175 ncopies);
7176 tmp = build1_v (GOTO_EXPR, exit_label);
7177 TREE_USED (exit_label) = 1;
7178 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7179 build_empty_stmt (input_location));
7180 gfc_add_expr_to_block (&body, tmp);
7181
7182 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7183 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7184 fold_convert (gfc_charlen_type_node, slen),
7185 fold_convert (gfc_charlen_type_node, count));
7186 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7187 tmp, fold_convert (gfc_charlen_type_node, size));
7188 tmp = fold_build_pointer_plus_loc (input_location,
7189 fold_convert (pvoid_type_node, dest), tmp);
7190 tmp = build_call_expr_loc (input_location,
7191 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7192 3, tmp, src,
7193 fold_build2_loc (input_location, MULT_EXPR,
7194 size_type_node, slen,
7195 fold_convert (size_type_node,
7196 size)));
7197 gfc_add_expr_to_block (&body, tmp);
7198
7199 /* Increment count. */
7200 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
7201 count, build_int_cst (TREE_TYPE (count), 1));
7202 gfc_add_modify (&body, count, tmp);
7203
7204 /* Build the loop. */
7205 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
7206 gfc_add_expr_to_block (&block, tmp);
7207
7208 /* Add the exit label. */
7209 tmp = build1_v (LABEL_EXPR, exit_label);
7210 gfc_add_expr_to_block (&block, tmp);
7211
7212 /* Finish the block. */
7213 tmp = gfc_finish_block (&block);
7214 gfc_add_expr_to_block (&se->pre, tmp);
7215
7216 /* Set the result value. */
7217 se->expr = dest;
7218 se->string_length = dlen;
7219 }
7220
7221
7222 /* Generate code for the IARGC intrinsic. */
7223
7224 static void
gfc_conv_intrinsic_iargc(gfc_se * se,gfc_expr * expr)7225 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
7226 {
7227 tree tmp;
7228 tree fndecl;
7229 tree type;
7230
7231 /* Call the library function. This always returns an INTEGER(4). */
7232 fndecl = gfor_fndecl_iargc;
7233 tmp = build_call_expr_loc (input_location,
7234 fndecl, 0);
7235
7236 /* Convert it to the required type. */
7237 type = gfc_typenode_for_spec (&expr->ts);
7238 tmp = fold_convert (type, tmp);
7239
7240 se->expr = tmp;
7241 }
7242
7243
7244 /* The loc intrinsic returns the address of its argument as
7245 gfc_index_integer_kind integer. */
7246
7247 static void
gfc_conv_intrinsic_loc(gfc_se * se,gfc_expr * expr)7248 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
7249 {
7250 tree temp_var;
7251 gfc_expr *arg_expr;
7252
7253 gcc_assert (!se->ss);
7254
7255 arg_expr = expr->value.function.actual->expr;
7256 if (arg_expr->rank == 0)
7257 {
7258 if (arg_expr->ts.type == BT_CLASS)
7259 gfc_add_component_ref (arg_expr, "_data");
7260 gfc_conv_expr_reference (se, arg_expr);
7261 }
7262 else
7263 gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
7264 se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
7265
7266 /* Create a temporary variable for loc return value. Without this,
7267 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7268 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
7269 gfc_add_modify (&se->pre, temp_var, se->expr);
7270 se->expr = temp_var;
7271 }
7272
7273
7274 /* The following routine generates code for the intrinsic
7275 functions from the ISO_C_BINDING module:
7276 * C_LOC
7277 * C_FUNLOC
7278 * C_ASSOCIATED */
7279
7280 static void
conv_isocbinding_function(gfc_se * se,gfc_expr * expr)7281 conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
7282 {
7283 gfc_actual_arglist *arg = expr->value.function.actual;
7284
7285 if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
7286 {
7287 if (arg->expr->rank == 0)
7288 gfc_conv_expr_reference (se, arg->expr);
7289 else if (gfc_is_simply_contiguous (arg->expr, false, false))
7290 gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
7291 else
7292 {
7293 gfc_conv_expr_descriptor (se, arg->expr);
7294 se->expr = gfc_conv_descriptor_data_get (se->expr);
7295 }
7296
7297 /* TODO -- the following two lines shouldn't be necessary, but if
7298 they're removed, a bug is exposed later in the code path.
7299 This workaround was thus introduced, but will have to be
7300 removed; please see PR 35150 for details about the issue. */
7301 se->expr = convert (pvoid_type_node, se->expr);
7302 se->expr = gfc_evaluate_now (se->expr, &se->pre);
7303 }
7304 else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
7305 gfc_conv_expr_reference (se, arg->expr);
7306 else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
7307 {
7308 gfc_se arg1se;
7309 gfc_se arg2se;
7310
7311 /* Build the addr_expr for the first argument. The argument is
7312 already an *address* so we don't need to set want_pointer in
7313 the gfc_se. */
7314 gfc_init_se (&arg1se, NULL);
7315 gfc_conv_expr (&arg1se, arg->expr);
7316 gfc_add_block_to_block (&se->pre, &arg1se.pre);
7317 gfc_add_block_to_block (&se->post, &arg1se.post);
7318
7319 /* See if we were given two arguments. */
7320 if (arg->next->expr == NULL)
7321 /* Only given one arg so generate a null and do a
7322 not-equal comparison against the first arg. */
7323 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7324 arg1se.expr,
7325 fold_convert (TREE_TYPE (arg1se.expr),
7326 null_pointer_node));
7327 else
7328 {
7329 tree eq_expr;
7330 tree not_null_expr;
7331
7332 /* Given two arguments so build the arg2se from second arg. */
7333 gfc_init_se (&arg2se, NULL);
7334 gfc_conv_expr (&arg2se, arg->next->expr);
7335 gfc_add_block_to_block (&se->pre, &arg2se.pre);
7336 gfc_add_block_to_block (&se->post, &arg2se.post);
7337
7338 /* Generate test to compare that the two args are equal. */
7339 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7340 arg1se.expr, arg2se.expr);
7341 /* Generate test to ensure that the first arg is not null. */
7342 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
7343 boolean_type_node,
7344 arg1se.expr, null_pointer_node);
7345
7346 /* Finally, the generated test must check that both arg1 is not
7347 NULL and that it is equal to the second arg. */
7348 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7349 boolean_type_node,
7350 not_null_expr, eq_expr);
7351 }
7352 }
7353 else
7354 gcc_unreachable ();
7355 }
7356
7357
7358 /* The following routine generates code for the intrinsic
7359 subroutines from the ISO_C_BINDING module:
7360 * C_F_POINTER
7361 * C_F_PROCPOINTER. */
7362
7363 static tree
conv_isocbinding_subroutine(gfc_code * code)7364 conv_isocbinding_subroutine (gfc_code *code)
7365 {
7366 gfc_se se;
7367 gfc_se cptrse;
7368 gfc_se fptrse;
7369 gfc_se shapese;
7370 gfc_ss *shape_ss;
7371 tree desc, dim, tmp, stride, offset;
7372 stmtblock_t body, block;
7373 gfc_loopinfo loop;
7374 gfc_actual_arglist *arg = code->ext.actual;
7375
7376 gfc_init_se (&se, NULL);
7377 gfc_init_se (&cptrse, NULL);
7378 gfc_conv_expr (&cptrse, arg->expr);
7379 gfc_add_block_to_block (&se.pre, &cptrse.pre);
7380 gfc_add_block_to_block (&se.post, &cptrse.post);
7381
7382 gfc_init_se (&fptrse, NULL);
7383 if (arg->next->expr->rank == 0)
7384 {
7385 fptrse.want_pointer = 1;
7386 gfc_conv_expr (&fptrse, arg->next->expr);
7387 gfc_add_block_to_block (&se.pre, &fptrse.pre);
7388 gfc_add_block_to_block (&se.post, &fptrse.post);
7389 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
7390 && arg->next->expr->symtree->n.sym->attr.dummy)
7391 fptrse.expr = build_fold_indirect_ref_loc (input_location,
7392 fptrse.expr);
7393 se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
7394 TREE_TYPE (fptrse.expr),
7395 fptrse.expr,
7396 fold_convert (TREE_TYPE (fptrse.expr),
7397 cptrse.expr));
7398 gfc_add_expr_to_block (&se.pre, se.expr);
7399 gfc_add_block_to_block (&se.pre, &se.post);
7400 return gfc_finish_block (&se.pre);
7401 }
7402
7403 gfc_start_block (&block);
7404
7405 /* Get the descriptor of the Fortran pointer. */
7406 fptrse.descriptor_only = 1;
7407 gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
7408 gfc_add_block_to_block (&block, &fptrse.pre);
7409 desc = fptrse.expr;
7410
7411 /* Set data value, dtype, and offset. */
7412 tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
7413 gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
7414 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
7415 gfc_get_dtype (TREE_TYPE (desc)));
7416
7417 /* Start scalarization of the bounds, using the shape argument. */
7418
7419 shape_ss = gfc_walk_expr (arg->next->next->expr);
7420 gcc_assert (shape_ss != gfc_ss_terminator);
7421 gfc_init_se (&shapese, NULL);
7422
7423 gfc_init_loopinfo (&loop);
7424 gfc_add_ss_to_loop (&loop, shape_ss);
7425 gfc_conv_ss_startstride (&loop);
7426 gfc_conv_loop_setup (&loop, &arg->next->expr->where);
7427 gfc_mark_ss_chain_used (shape_ss, 1);
7428
7429 gfc_copy_loopinfo_to_se (&shapese, &loop);
7430 shapese.ss = shape_ss;
7431
7432 stride = gfc_create_var (gfc_array_index_type, "stride");
7433 offset = gfc_create_var (gfc_array_index_type, "offset");
7434 gfc_add_modify (&block, stride, gfc_index_one_node);
7435 gfc_add_modify (&block, offset, gfc_index_zero_node);
7436
7437 /* Loop body. */
7438 gfc_start_scalarized_body (&loop, &body);
7439
7440 dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7441 loop.loopvar[0], loop.from[0]);
7442
7443 /* Set bounds and stride. */
7444 gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
7445 gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
7446
7447 gfc_conv_expr (&shapese, arg->next->next->expr);
7448 gfc_add_block_to_block (&body, &shapese.pre);
7449 gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
7450 gfc_add_block_to_block (&body, &shapese.post);
7451
7452 /* Calculate offset. */
7453 gfc_add_modify (&body, offset,
7454 fold_build2_loc (input_location, PLUS_EXPR,
7455 gfc_array_index_type, offset, stride));
7456 /* Update stride. */
7457 gfc_add_modify (&body, stride,
7458 fold_build2_loc (input_location, MULT_EXPR,
7459 gfc_array_index_type, stride,
7460 fold_convert (gfc_array_index_type,
7461 shapese.expr)));
7462 /* Finish scalarization loop. */
7463 gfc_trans_scalarizing_loops (&loop, &body);
7464 gfc_add_block_to_block (&block, &loop.pre);
7465 gfc_add_block_to_block (&block, &loop.post);
7466 gfc_add_block_to_block (&block, &fptrse.post);
7467 gfc_cleanup_loop (&loop);
7468
7469 gfc_add_modify (&block, offset,
7470 fold_build1_loc (input_location, NEGATE_EXPR,
7471 gfc_array_index_type, offset));
7472 gfc_conv_descriptor_offset_set (&block, desc, offset);
7473
7474 gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
7475 gfc_add_block_to_block (&se.pre, &se.post);
7476 return gfc_finish_block (&se.pre);
7477 }
7478
7479
7480 /* Save and restore floating-point state. */
7481
7482 tree
gfc_save_fp_state(stmtblock_t * block)7483 gfc_save_fp_state (stmtblock_t *block)
7484 {
7485 tree type, fpstate, tmp;
7486
7487 type = build_array_type (char_type_node,
7488 build_range_type (size_type_node, size_zero_node,
7489 size_int (GFC_FPE_STATE_BUFFER_SIZE)));
7490 fpstate = gfc_create_var (type, "fpstate");
7491 fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
7492
7493 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
7494 1, fpstate);
7495 gfc_add_expr_to_block (block, tmp);
7496
7497 return fpstate;
7498 }
7499
7500
7501 void
gfc_restore_fp_state(stmtblock_t * block,tree fpstate)7502 gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
7503 {
7504 tree tmp;
7505
7506 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
7507 1, fpstate);
7508 gfc_add_expr_to_block (block, tmp);
7509 }
7510
7511
7512 /* Generate code for arguments of IEEE functions. */
7513
7514 static void
conv_ieee_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)7515 conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
7516 int nargs)
7517 {
7518 gfc_actual_arglist *actual;
7519 gfc_expr *e;
7520 gfc_se argse;
7521 int arg;
7522
7523 actual = expr->value.function.actual;
7524 for (arg = 0; arg < nargs; arg++, actual = actual->next)
7525 {
7526 gcc_assert (actual);
7527 e = actual->expr;
7528
7529 gfc_init_se (&argse, se);
7530 gfc_conv_expr_val (&argse, e);
7531
7532 gfc_add_block_to_block (&se->pre, &argse.pre);
7533 gfc_add_block_to_block (&se->post, &argse.post);
7534 argarray[arg] = argse.expr;
7535 }
7536 }
7537
7538
7539 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7540 and IEEE_UNORDERED, which translate directly to GCC type-generic
7541 built-ins. */
7542
7543 static void
conv_intrinsic_ieee_builtin(gfc_se * se,gfc_expr * expr,enum built_in_function code,int nargs)7544 conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
7545 enum built_in_function code, int nargs)
7546 {
7547 tree args[2];
7548 gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0]));
7549
7550 conv_ieee_function_args (se, expr, args, nargs);
7551 se->expr = build_call_expr_loc_array (input_location,
7552 builtin_decl_explicit (code),
7553 nargs, args);
7554 STRIP_TYPE_NOPS (se->expr);
7555 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7556 }
7557
7558
7559 /* Generate code for IEEE_IS_NORMAL intrinsic:
7560 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7561
7562 static void
conv_intrinsic_ieee_is_normal(gfc_se * se,gfc_expr * expr)7563 conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
7564 {
7565 tree arg, isnormal, iszero;
7566
7567 /* Convert arg, evaluate it only once. */
7568 conv_ieee_function_args (se, expr, &arg, 1);
7569 arg = gfc_evaluate_now (arg, &se->pre);
7570
7571 isnormal = build_call_expr_loc (input_location,
7572 builtin_decl_explicit (BUILT_IN_ISNORMAL),
7573 1, arg);
7574 iszero = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
7575 build_real_from_int_cst (TREE_TYPE (arg),
7576 integer_zero_node));
7577 se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7578 boolean_type_node, isnormal, iszero);
7579 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7580 }
7581
7582
7583 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7584 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7585
7586 static void
conv_intrinsic_ieee_is_negative(gfc_se * se,gfc_expr * expr)7587 conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
7588 {
7589 tree arg, signbit, isnan;
7590
7591 /* Convert arg, evaluate it only once. */
7592 conv_ieee_function_args (se, expr, &arg, 1);
7593 arg = gfc_evaluate_now (arg, &se->pre);
7594
7595 isnan = build_call_expr_loc (input_location,
7596 builtin_decl_explicit (BUILT_IN_ISNAN),
7597 1, arg);
7598 STRIP_TYPE_NOPS (isnan);
7599
7600 signbit = build_call_expr_loc (input_location,
7601 builtin_decl_explicit (BUILT_IN_SIGNBIT),
7602 1, arg);
7603 signbit = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7604 signbit, integer_zero_node);
7605
7606 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7607 boolean_type_node, signbit,
7608 fold_build1_loc (input_location, TRUTH_NOT_EXPR,
7609 TREE_TYPE(isnan), isnan));
7610
7611 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7612 }
7613
7614
7615 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7616
7617 static void
conv_intrinsic_ieee_logb_rint(gfc_se * se,gfc_expr * expr,enum built_in_function code)7618 conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
7619 enum built_in_function code)
7620 {
7621 tree arg, decl, call, fpstate;
7622 int argprec;
7623
7624 conv_ieee_function_args (se, expr, &arg, 1);
7625 argprec = TYPE_PRECISION (TREE_TYPE (arg));
7626 decl = builtin_decl_for_precision (code, argprec);
7627
7628 /* Save floating-point state. */
7629 fpstate = gfc_save_fp_state (&se->pre);
7630
7631 /* Make the function call. */
7632 call = build_call_expr_loc (input_location, decl, 1, arg);
7633 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
7634
7635 /* Restore floating-point state. */
7636 gfc_restore_fp_state (&se->post, fpstate);
7637 }
7638
7639
7640 /* Generate code for IEEE_REM. */
7641
7642 static void
conv_intrinsic_ieee_rem(gfc_se * se,gfc_expr * expr)7643 conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
7644 {
7645 tree args[2], decl, call, fpstate;
7646 int argprec;
7647
7648 conv_ieee_function_args (se, expr, args, 2);
7649
7650 /* If arguments have unequal size, convert them to the larger. */
7651 if (TYPE_PRECISION (TREE_TYPE (args[0]))
7652 > TYPE_PRECISION (TREE_TYPE (args[1])))
7653 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
7654 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
7655 > TYPE_PRECISION (TREE_TYPE (args[0])))
7656 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
7657
7658 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
7659 decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
7660
7661 /* Save floating-point state. */
7662 fpstate = gfc_save_fp_state (&se->pre);
7663
7664 /* Make the function call. */
7665 call = build_call_expr_loc_array (input_location, decl, 2, args);
7666 se->expr = fold_convert (TREE_TYPE (args[0]), call);
7667
7668 /* Restore floating-point state. */
7669 gfc_restore_fp_state (&se->post, fpstate);
7670 }
7671
7672
7673 /* Generate code for IEEE_NEXT_AFTER. */
7674
7675 static void
conv_intrinsic_ieee_next_after(gfc_se * se,gfc_expr * expr)7676 conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
7677 {
7678 tree args[2], decl, call, fpstate;
7679 int argprec;
7680
7681 conv_ieee_function_args (se, expr, args, 2);
7682
7683 /* Result has the characteristics of first argument. */
7684 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
7685 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
7686 decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
7687
7688 /* Save floating-point state. */
7689 fpstate = gfc_save_fp_state (&se->pre);
7690
7691 /* Make the function call. */
7692 call = build_call_expr_loc_array (input_location, decl, 2, args);
7693 se->expr = fold_convert (TREE_TYPE (args[0]), call);
7694
7695 /* Restore floating-point state. */
7696 gfc_restore_fp_state (&se->post, fpstate);
7697 }
7698
7699
7700 /* Generate code for IEEE_SCALB. */
7701
7702 static void
conv_intrinsic_ieee_scalb(gfc_se * se,gfc_expr * expr)7703 conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
7704 {
7705 tree args[2], decl, call, huge, type;
7706 int argprec, n;
7707
7708 conv_ieee_function_args (se, expr, args, 2);
7709
7710 /* Result has the characteristics of first argument. */
7711 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
7712 decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
7713
7714 if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
7715 {
7716 /* We need to fold the integer into the range of a C int. */
7717 args[1] = gfc_evaluate_now (args[1], &se->pre);
7718 type = TREE_TYPE (args[1]);
7719
7720 n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
7721 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
7722 gfc_c_int_kind);
7723 huge = fold_convert (type, huge);
7724 args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
7725 huge);
7726 args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
7727 fold_build1_loc (input_location, NEGATE_EXPR,
7728 type, huge));
7729 }
7730
7731 args[1] = fold_convert (integer_type_node, args[1]);
7732
7733 /* Make the function call. */
7734 call = build_call_expr_loc_array (input_location, decl, 2, args);
7735 se->expr = fold_convert (TREE_TYPE (args[0]), call);
7736 }
7737
7738
7739 /* Generate code for IEEE_COPY_SIGN. */
7740
7741 static void
conv_intrinsic_ieee_copy_sign(gfc_se * se,gfc_expr * expr)7742 conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
7743 {
7744 tree args[2], decl, sign;
7745 int argprec;
7746
7747 conv_ieee_function_args (se, expr, args, 2);
7748
7749 /* Get the sign of the second argument. */
7750 sign = build_call_expr_loc (input_location,
7751 builtin_decl_explicit (BUILT_IN_SIGNBIT),
7752 1, args[1]);
7753 sign = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7754 sign, integer_zero_node);
7755
7756 /* Create a value of one, with the right sign. */
7757 sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
7758 sign,
7759 fold_build1_loc (input_location, NEGATE_EXPR,
7760 integer_type_node,
7761 integer_one_node),
7762 integer_one_node);
7763 args[1] = fold_convert (TREE_TYPE (args[0]), sign);
7764
7765 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
7766 decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
7767
7768 se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
7769 }
7770
7771
7772 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7773 module. */
7774
7775 bool
gfc_conv_ieee_arithmetic_function(gfc_se * se,gfc_expr * expr)7776 gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
7777 {
7778 const char *name = expr->value.function.name;
7779
7780 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7781
7782 if (STARTS_WITH (name, "_gfortran_ieee_is_nan"))
7783 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
7784 else if (STARTS_WITH (name, "_gfortran_ieee_is_finite"))
7785 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
7786 else if (STARTS_WITH (name, "_gfortran_ieee_unordered"))
7787 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
7788 else if (STARTS_WITH (name, "_gfortran_ieee_is_normal"))
7789 conv_intrinsic_ieee_is_normal (se, expr);
7790 else if (STARTS_WITH (name, "_gfortran_ieee_is_negative"))
7791 conv_intrinsic_ieee_is_negative (se, expr);
7792 else if (STARTS_WITH (name, "_gfortran_ieee_copy_sign"))
7793 conv_intrinsic_ieee_copy_sign (se, expr);
7794 else if (STARTS_WITH (name, "_gfortran_ieee_scalb"))
7795 conv_intrinsic_ieee_scalb (se, expr);
7796 else if (STARTS_WITH (name, "_gfortran_ieee_next_after"))
7797 conv_intrinsic_ieee_next_after (se, expr);
7798 else if (STARTS_WITH (name, "_gfortran_ieee_rem"))
7799 conv_intrinsic_ieee_rem (se, expr);
7800 else if (STARTS_WITH (name, "_gfortran_ieee_logb"))
7801 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
7802 else if (STARTS_WITH (name, "_gfortran_ieee_rint"))
7803 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
7804 else
7805 /* It is not among the functions we translate directly. We return
7806 false, so a library function call is emitted. */
7807 return false;
7808
7809 #undef STARTS_WITH
7810
7811 return true;
7812 }
7813
7814
7815 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
7816
7817 static void
gfc_conv_intrinsic_malloc(gfc_se * se,gfc_expr * expr)7818 gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
7819 {
7820 tree arg, res, restype;
7821
7822 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7823 arg = fold_convert (size_type_node, arg);
7824 res = build_call_expr_loc (input_location,
7825 builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
7826 restype = gfc_typenode_for_spec (&expr->ts);
7827 se->expr = fold_convert (restype, res);
7828 }
7829
7830
7831 /* Generate code for an intrinsic function. Some map directly to library
7832 calls, others get special handling. In some cases the name of the function
7833 used depends on the type specifiers. */
7834
7835 void
gfc_conv_intrinsic_function(gfc_se * se,gfc_expr * expr)7836 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
7837 {
7838 const char *name;
7839 int lib, kind;
7840 tree fndecl;
7841
7842 name = &expr->value.function.name[2];
7843
7844 if (expr->rank > 0)
7845 {
7846 lib = gfc_is_intrinsic_libcall (expr);
7847 if (lib != 0)
7848 {
7849 if (lib == 1)
7850 se->ignore_optional = 1;
7851
7852 switch (expr->value.function.isym->id)
7853 {
7854 case GFC_ISYM_EOSHIFT:
7855 case GFC_ISYM_PACK:
7856 case GFC_ISYM_RESHAPE:
7857 /* For all of those the first argument specifies the type and the
7858 third is optional. */
7859 conv_generic_with_optional_char_arg (se, expr, 1, 3);
7860 break;
7861
7862 case GFC_ISYM_SHAPE:
7863 gfc_conv_intrinsic_shape (se, expr);
7864 break;
7865
7866 default:
7867 gfc_conv_intrinsic_funcall (se, expr);
7868 break;
7869 }
7870
7871 return;
7872 }
7873 }
7874
7875 switch (expr->value.function.isym->id)
7876 {
7877 case GFC_ISYM_NONE:
7878 gcc_unreachable ();
7879
7880 case GFC_ISYM_REPEAT:
7881 gfc_conv_intrinsic_repeat (se, expr);
7882 break;
7883
7884 case GFC_ISYM_TRIM:
7885 gfc_conv_intrinsic_trim (se, expr);
7886 break;
7887
7888 case GFC_ISYM_SC_KIND:
7889 gfc_conv_intrinsic_sc_kind (se, expr);
7890 break;
7891
7892 case GFC_ISYM_SI_KIND:
7893 gfc_conv_intrinsic_si_kind (se, expr);
7894 break;
7895
7896 case GFC_ISYM_SR_KIND:
7897 gfc_conv_intrinsic_sr_kind (se, expr);
7898 break;
7899
7900 case GFC_ISYM_EXPONENT:
7901 gfc_conv_intrinsic_exponent (se, expr);
7902 break;
7903
7904 case GFC_ISYM_SCAN:
7905 kind = expr->value.function.actual->expr->ts.kind;
7906 if (kind == 1)
7907 fndecl = gfor_fndecl_string_scan;
7908 else if (kind == 4)
7909 fndecl = gfor_fndecl_string_scan_char4;
7910 else
7911 gcc_unreachable ();
7912
7913 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
7914 break;
7915
7916 case GFC_ISYM_VERIFY:
7917 kind = expr->value.function.actual->expr->ts.kind;
7918 if (kind == 1)
7919 fndecl = gfor_fndecl_string_verify;
7920 else if (kind == 4)
7921 fndecl = gfor_fndecl_string_verify_char4;
7922 else
7923 gcc_unreachable ();
7924
7925 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
7926 break;
7927
7928 case GFC_ISYM_ALLOCATED:
7929 gfc_conv_allocated (se, expr);
7930 break;
7931
7932 case GFC_ISYM_ASSOCIATED:
7933 gfc_conv_associated(se, expr);
7934 break;
7935
7936 case GFC_ISYM_SAME_TYPE_AS:
7937 gfc_conv_same_type_as (se, expr);
7938 break;
7939
7940 case GFC_ISYM_ABS:
7941 gfc_conv_intrinsic_abs (se, expr);
7942 break;
7943
7944 case GFC_ISYM_ADJUSTL:
7945 if (expr->ts.kind == 1)
7946 fndecl = gfor_fndecl_adjustl;
7947 else if (expr->ts.kind == 4)
7948 fndecl = gfor_fndecl_adjustl_char4;
7949 else
7950 gcc_unreachable ();
7951
7952 gfc_conv_intrinsic_adjust (se, expr, fndecl);
7953 break;
7954
7955 case GFC_ISYM_ADJUSTR:
7956 if (expr->ts.kind == 1)
7957 fndecl = gfor_fndecl_adjustr;
7958 else if (expr->ts.kind == 4)
7959 fndecl = gfor_fndecl_adjustr_char4;
7960 else
7961 gcc_unreachable ();
7962
7963 gfc_conv_intrinsic_adjust (se, expr, fndecl);
7964 break;
7965
7966 case GFC_ISYM_AIMAG:
7967 gfc_conv_intrinsic_imagpart (se, expr);
7968 break;
7969
7970 case GFC_ISYM_AINT:
7971 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
7972 break;
7973
7974 case GFC_ISYM_ALL:
7975 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
7976 break;
7977
7978 case GFC_ISYM_ANINT:
7979 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
7980 break;
7981
7982 case GFC_ISYM_AND:
7983 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
7984 break;
7985
7986 case GFC_ISYM_ANY:
7987 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
7988 break;
7989
7990 case GFC_ISYM_BTEST:
7991 gfc_conv_intrinsic_btest (se, expr);
7992 break;
7993
7994 case GFC_ISYM_BGE:
7995 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
7996 break;
7997
7998 case GFC_ISYM_BGT:
7999 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
8000 break;
8001
8002 case GFC_ISYM_BLE:
8003 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
8004 break;
8005
8006 case GFC_ISYM_BLT:
8007 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
8008 break;
8009
8010 case GFC_ISYM_C_ASSOCIATED:
8011 case GFC_ISYM_C_FUNLOC:
8012 case GFC_ISYM_C_LOC:
8013 conv_isocbinding_function (se, expr);
8014 break;
8015
8016 case GFC_ISYM_ACHAR:
8017 case GFC_ISYM_CHAR:
8018 gfc_conv_intrinsic_char (se, expr);
8019 break;
8020
8021 case GFC_ISYM_CONVERSION:
8022 case GFC_ISYM_REAL:
8023 case GFC_ISYM_LOGICAL:
8024 case GFC_ISYM_DBLE:
8025 gfc_conv_intrinsic_conversion (se, expr);
8026 break;
8027
8028 /* Integer conversions are handled separately to make sure we get the
8029 correct rounding mode. */
8030 case GFC_ISYM_INT:
8031 case GFC_ISYM_INT2:
8032 case GFC_ISYM_INT8:
8033 case GFC_ISYM_LONG:
8034 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
8035 break;
8036
8037 case GFC_ISYM_NINT:
8038 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
8039 break;
8040
8041 case GFC_ISYM_CEILING:
8042 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
8043 break;
8044
8045 case GFC_ISYM_FLOOR:
8046 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
8047 break;
8048
8049 case GFC_ISYM_MOD:
8050 gfc_conv_intrinsic_mod (se, expr, 0);
8051 break;
8052
8053 case GFC_ISYM_MODULO:
8054 gfc_conv_intrinsic_mod (se, expr, 1);
8055 break;
8056
8057 case GFC_ISYM_CAF_GET:
8058 gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE);
8059 break;
8060
8061 case GFC_ISYM_CMPLX:
8062 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
8063 break;
8064
8065 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
8066 gfc_conv_intrinsic_iargc (se, expr);
8067 break;
8068
8069 case GFC_ISYM_COMPLEX:
8070 gfc_conv_intrinsic_cmplx (se, expr, 1);
8071 break;
8072
8073 case GFC_ISYM_CONJG:
8074 gfc_conv_intrinsic_conjg (se, expr);
8075 break;
8076
8077 case GFC_ISYM_COUNT:
8078 gfc_conv_intrinsic_count (se, expr);
8079 break;
8080
8081 case GFC_ISYM_CTIME:
8082 gfc_conv_intrinsic_ctime (se, expr);
8083 break;
8084
8085 case GFC_ISYM_DIM:
8086 gfc_conv_intrinsic_dim (se, expr);
8087 break;
8088
8089 case GFC_ISYM_DOT_PRODUCT:
8090 gfc_conv_intrinsic_dot_product (se, expr);
8091 break;
8092
8093 case GFC_ISYM_DPROD:
8094 gfc_conv_intrinsic_dprod (se, expr);
8095 break;
8096
8097 case GFC_ISYM_DSHIFTL:
8098 gfc_conv_intrinsic_dshift (se, expr, true);
8099 break;
8100
8101 case GFC_ISYM_DSHIFTR:
8102 gfc_conv_intrinsic_dshift (se, expr, false);
8103 break;
8104
8105 case GFC_ISYM_FDATE:
8106 gfc_conv_intrinsic_fdate (se, expr);
8107 break;
8108
8109 case GFC_ISYM_FRACTION:
8110 gfc_conv_intrinsic_fraction (se, expr);
8111 break;
8112
8113 case GFC_ISYM_IALL:
8114 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
8115 break;
8116
8117 case GFC_ISYM_IAND:
8118 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
8119 break;
8120
8121 case GFC_ISYM_IANY:
8122 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
8123 break;
8124
8125 case GFC_ISYM_IBCLR:
8126 gfc_conv_intrinsic_singlebitop (se, expr, 0);
8127 break;
8128
8129 case GFC_ISYM_IBITS:
8130 gfc_conv_intrinsic_ibits (se, expr);
8131 break;
8132
8133 case GFC_ISYM_IBSET:
8134 gfc_conv_intrinsic_singlebitop (se, expr, 1);
8135 break;
8136
8137 case GFC_ISYM_IACHAR:
8138 case GFC_ISYM_ICHAR:
8139 /* We assume ASCII character sequence. */
8140 gfc_conv_intrinsic_ichar (se, expr);
8141 break;
8142
8143 case GFC_ISYM_IARGC:
8144 gfc_conv_intrinsic_iargc (se, expr);
8145 break;
8146
8147 case GFC_ISYM_IEOR:
8148 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
8149 break;
8150
8151 case GFC_ISYM_INDEX:
8152 kind = expr->value.function.actual->expr->ts.kind;
8153 if (kind == 1)
8154 fndecl = gfor_fndecl_string_index;
8155 else if (kind == 4)
8156 fndecl = gfor_fndecl_string_index_char4;
8157 else
8158 gcc_unreachable ();
8159
8160 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8161 break;
8162
8163 case GFC_ISYM_IOR:
8164 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
8165 break;
8166
8167 case GFC_ISYM_IPARITY:
8168 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
8169 break;
8170
8171 case GFC_ISYM_IS_IOSTAT_END:
8172 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
8173 break;
8174
8175 case GFC_ISYM_IS_IOSTAT_EOR:
8176 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
8177 break;
8178
8179 case GFC_ISYM_ISNAN:
8180 gfc_conv_intrinsic_isnan (se, expr);
8181 break;
8182
8183 case GFC_ISYM_LSHIFT:
8184 gfc_conv_intrinsic_shift (se, expr, false, false);
8185 break;
8186
8187 case GFC_ISYM_RSHIFT:
8188 gfc_conv_intrinsic_shift (se, expr, true, true);
8189 break;
8190
8191 case GFC_ISYM_SHIFTA:
8192 gfc_conv_intrinsic_shift (se, expr, true, true);
8193 break;
8194
8195 case GFC_ISYM_SHIFTL:
8196 gfc_conv_intrinsic_shift (se, expr, false, false);
8197 break;
8198
8199 case GFC_ISYM_SHIFTR:
8200 gfc_conv_intrinsic_shift (se, expr, true, false);
8201 break;
8202
8203 case GFC_ISYM_ISHFT:
8204 gfc_conv_intrinsic_ishft (se, expr);
8205 break;
8206
8207 case GFC_ISYM_ISHFTC:
8208 gfc_conv_intrinsic_ishftc (se, expr);
8209 break;
8210
8211 case GFC_ISYM_LEADZ:
8212 gfc_conv_intrinsic_leadz (se, expr);
8213 break;
8214
8215 case GFC_ISYM_TRAILZ:
8216 gfc_conv_intrinsic_trailz (se, expr);
8217 break;
8218
8219 case GFC_ISYM_POPCNT:
8220 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
8221 break;
8222
8223 case GFC_ISYM_POPPAR:
8224 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
8225 break;
8226
8227 case GFC_ISYM_LBOUND:
8228 gfc_conv_intrinsic_bound (se, expr, 0);
8229 break;
8230
8231 case GFC_ISYM_LCOBOUND:
8232 conv_intrinsic_cobound (se, expr);
8233 break;
8234
8235 case GFC_ISYM_TRANSPOSE:
8236 /* The scalarizer has already been set up for reversed dimension access
8237 order ; now we just get the argument value normally. */
8238 gfc_conv_expr (se, expr->value.function.actual->expr);
8239 break;
8240
8241 case GFC_ISYM_LEN:
8242 gfc_conv_intrinsic_len (se, expr);
8243 break;
8244
8245 case GFC_ISYM_LEN_TRIM:
8246 gfc_conv_intrinsic_len_trim (se, expr);
8247 break;
8248
8249 case GFC_ISYM_LGE:
8250 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
8251 break;
8252
8253 case GFC_ISYM_LGT:
8254 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
8255 break;
8256
8257 case GFC_ISYM_LLE:
8258 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
8259 break;
8260
8261 case GFC_ISYM_LLT:
8262 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
8263 break;
8264
8265 case GFC_ISYM_MALLOC:
8266 gfc_conv_intrinsic_malloc (se, expr);
8267 break;
8268
8269 case GFC_ISYM_MASKL:
8270 gfc_conv_intrinsic_mask (se, expr, 1);
8271 break;
8272
8273 case GFC_ISYM_MASKR:
8274 gfc_conv_intrinsic_mask (se, expr, 0);
8275 break;
8276
8277 case GFC_ISYM_MAX:
8278 if (expr->ts.type == BT_CHARACTER)
8279 gfc_conv_intrinsic_minmax_char (se, expr, 1);
8280 else
8281 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
8282 break;
8283
8284 case GFC_ISYM_MAXLOC:
8285 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
8286 break;
8287
8288 case GFC_ISYM_MAXVAL:
8289 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
8290 break;
8291
8292 case GFC_ISYM_MERGE:
8293 gfc_conv_intrinsic_merge (se, expr);
8294 break;
8295
8296 case GFC_ISYM_MERGE_BITS:
8297 gfc_conv_intrinsic_merge_bits (se, expr);
8298 break;
8299
8300 case GFC_ISYM_MIN:
8301 if (expr->ts.type == BT_CHARACTER)
8302 gfc_conv_intrinsic_minmax_char (se, expr, -1);
8303 else
8304 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
8305 break;
8306
8307 case GFC_ISYM_MINLOC:
8308 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
8309 break;
8310
8311 case GFC_ISYM_MINVAL:
8312 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
8313 break;
8314
8315 case GFC_ISYM_NEAREST:
8316 gfc_conv_intrinsic_nearest (se, expr);
8317 break;
8318
8319 case GFC_ISYM_NORM2:
8320 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
8321 break;
8322
8323 case GFC_ISYM_NOT:
8324 gfc_conv_intrinsic_not (se, expr);
8325 break;
8326
8327 case GFC_ISYM_OR:
8328 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
8329 break;
8330
8331 case GFC_ISYM_PARITY:
8332 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
8333 break;
8334
8335 case GFC_ISYM_PRESENT:
8336 gfc_conv_intrinsic_present (se, expr);
8337 break;
8338
8339 case GFC_ISYM_PRODUCT:
8340 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
8341 break;
8342
8343 case GFC_ISYM_RANK:
8344 gfc_conv_intrinsic_rank (se, expr);
8345 break;
8346
8347 case GFC_ISYM_RRSPACING:
8348 gfc_conv_intrinsic_rrspacing (se, expr);
8349 break;
8350
8351 case GFC_ISYM_SET_EXPONENT:
8352 gfc_conv_intrinsic_set_exponent (se, expr);
8353 break;
8354
8355 case GFC_ISYM_SCALE:
8356 gfc_conv_intrinsic_scale (se, expr);
8357 break;
8358
8359 case GFC_ISYM_SIGN:
8360 gfc_conv_intrinsic_sign (se, expr);
8361 break;
8362
8363 case GFC_ISYM_SIZE:
8364 gfc_conv_intrinsic_size (se, expr);
8365 break;
8366
8367 case GFC_ISYM_SIZEOF:
8368 case GFC_ISYM_C_SIZEOF:
8369 gfc_conv_intrinsic_sizeof (se, expr);
8370 break;
8371
8372 case GFC_ISYM_STORAGE_SIZE:
8373 gfc_conv_intrinsic_storage_size (se, expr);
8374 break;
8375
8376 case GFC_ISYM_SPACING:
8377 gfc_conv_intrinsic_spacing (se, expr);
8378 break;
8379
8380 case GFC_ISYM_STRIDE:
8381 conv_intrinsic_stride (se, expr);
8382 break;
8383
8384 case GFC_ISYM_SUM:
8385 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
8386 break;
8387
8388 case GFC_ISYM_TRANSFER:
8389 if (se->ss && se->ss->info->useflags)
8390 /* Access the previously obtained result. */
8391 gfc_conv_tmp_array_ref (se);
8392 else
8393 gfc_conv_intrinsic_transfer (se, expr);
8394 break;
8395
8396 case GFC_ISYM_TTYNAM:
8397 gfc_conv_intrinsic_ttynam (se, expr);
8398 break;
8399
8400 case GFC_ISYM_UBOUND:
8401 gfc_conv_intrinsic_bound (se, expr, 1);
8402 break;
8403
8404 case GFC_ISYM_UCOBOUND:
8405 conv_intrinsic_cobound (se, expr);
8406 break;
8407
8408 case GFC_ISYM_XOR:
8409 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
8410 break;
8411
8412 case GFC_ISYM_LOC:
8413 gfc_conv_intrinsic_loc (se, expr);
8414 break;
8415
8416 case GFC_ISYM_THIS_IMAGE:
8417 /* For num_images() == 1, handle as LCOBOUND. */
8418 if (expr->value.function.actual->expr
8419 && flag_coarray == GFC_FCOARRAY_SINGLE)
8420 conv_intrinsic_cobound (se, expr);
8421 else
8422 trans_this_image (se, expr);
8423 break;
8424
8425 case GFC_ISYM_IMAGE_INDEX:
8426 trans_image_index (se, expr);
8427 break;
8428
8429 case GFC_ISYM_NUM_IMAGES:
8430 trans_num_images (se, expr);
8431 break;
8432
8433 case GFC_ISYM_ACCESS:
8434 case GFC_ISYM_CHDIR:
8435 case GFC_ISYM_CHMOD:
8436 case GFC_ISYM_DTIME:
8437 case GFC_ISYM_ETIME:
8438 case GFC_ISYM_EXTENDS_TYPE_OF:
8439 case GFC_ISYM_FGET:
8440 case GFC_ISYM_FGETC:
8441 case GFC_ISYM_FNUM:
8442 case GFC_ISYM_FPUT:
8443 case GFC_ISYM_FPUTC:
8444 case GFC_ISYM_FSTAT:
8445 case GFC_ISYM_FTELL:
8446 case GFC_ISYM_GETCWD:
8447 case GFC_ISYM_GETGID:
8448 case GFC_ISYM_GETPID:
8449 case GFC_ISYM_GETUID:
8450 case GFC_ISYM_HOSTNM:
8451 case GFC_ISYM_KILL:
8452 case GFC_ISYM_IERRNO:
8453 case GFC_ISYM_IRAND:
8454 case GFC_ISYM_ISATTY:
8455 case GFC_ISYM_JN2:
8456 case GFC_ISYM_LINK:
8457 case GFC_ISYM_LSTAT:
8458 case GFC_ISYM_MATMUL:
8459 case GFC_ISYM_MCLOCK:
8460 case GFC_ISYM_MCLOCK8:
8461 case GFC_ISYM_RAND:
8462 case GFC_ISYM_RENAME:
8463 case GFC_ISYM_SECOND:
8464 case GFC_ISYM_SECNDS:
8465 case GFC_ISYM_SIGNAL:
8466 case GFC_ISYM_STAT:
8467 case GFC_ISYM_SYMLNK:
8468 case GFC_ISYM_SYSTEM:
8469 case GFC_ISYM_TIME:
8470 case GFC_ISYM_TIME8:
8471 case GFC_ISYM_UMASK:
8472 case GFC_ISYM_UNLINK:
8473 case GFC_ISYM_YN2:
8474 gfc_conv_intrinsic_funcall (se, expr);
8475 break;
8476
8477 case GFC_ISYM_EOSHIFT:
8478 case GFC_ISYM_PACK:
8479 case GFC_ISYM_RESHAPE:
8480 /* For those, expr->rank should always be >0 and thus the if above the
8481 switch should have matched. */
8482 gcc_unreachable ();
8483 break;
8484
8485 default:
8486 gfc_conv_intrinsic_lib_function (se, expr);
8487 break;
8488 }
8489 }
8490
8491
8492 static gfc_ss *
walk_inline_intrinsic_transpose(gfc_ss * ss,gfc_expr * expr)8493 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
8494 {
8495 gfc_ss *arg_ss, *tmp_ss;
8496 gfc_actual_arglist *arg;
8497
8498 arg = expr->value.function.actual;
8499
8500 gcc_assert (arg->expr);
8501
8502 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
8503 gcc_assert (arg_ss != gfc_ss_terminator);
8504
8505 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
8506 {
8507 if (tmp_ss->info->type != GFC_SS_SCALAR
8508 && tmp_ss->info->type != GFC_SS_REFERENCE)
8509 {
8510 gcc_assert (tmp_ss->dimen == 2);
8511
8512 /* We just invert dimensions. */
8513 std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
8514 }
8515
8516 /* Stop when tmp_ss points to the last valid element of the chain... */
8517 if (tmp_ss->next == gfc_ss_terminator)
8518 break;
8519 }
8520
8521 /* ... so that we can attach the rest of the chain to it. */
8522 tmp_ss->next = ss;
8523
8524 return arg_ss;
8525 }
8526
8527
8528 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8529 This has the side effect of reversing the nested list, so there is no
8530 need to call gfc_reverse_ss on it (the given list is assumed not to be
8531 reversed yet). */
8532
8533 static gfc_ss *
nest_loop_dimension(gfc_ss * ss,int dim)8534 nest_loop_dimension (gfc_ss *ss, int dim)
8535 {
8536 int ss_dim, i;
8537 gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
8538 gfc_loopinfo *new_loop;
8539
8540 gcc_assert (ss != gfc_ss_terminator);
8541
8542 for (; ss != gfc_ss_terminator; ss = ss->next)
8543 {
8544 new_ss = gfc_get_ss ();
8545 new_ss->next = prev_ss;
8546 new_ss->parent = ss;
8547 new_ss->info = ss->info;
8548 new_ss->info->refcount++;
8549 if (ss->dimen != 0)
8550 {
8551 gcc_assert (ss->info->type != GFC_SS_SCALAR
8552 && ss->info->type != GFC_SS_REFERENCE);
8553
8554 new_ss->dimen = 1;
8555 new_ss->dim[0] = ss->dim[dim];
8556
8557 gcc_assert (dim < ss->dimen);
8558
8559 ss_dim = --ss->dimen;
8560 for (i = dim; i < ss_dim; i++)
8561 ss->dim[i] = ss->dim[i + 1];
8562
8563 ss->dim[ss_dim] = 0;
8564 }
8565 prev_ss = new_ss;
8566
8567 if (ss->nested_ss)
8568 {
8569 ss->nested_ss->parent = new_ss;
8570 new_ss->nested_ss = ss->nested_ss;
8571 }
8572 ss->nested_ss = new_ss;
8573 }
8574
8575 new_loop = gfc_get_loopinfo ();
8576 gfc_init_loopinfo (new_loop);
8577
8578 gcc_assert (prev_ss != NULL);
8579 gcc_assert (prev_ss != gfc_ss_terminator);
8580 gfc_add_ss_to_loop (new_loop, prev_ss);
8581 return new_ss->parent;
8582 }
8583
8584
8585 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8586 is to be inlined. */
8587
8588 static gfc_ss *
walk_inline_intrinsic_arith(gfc_ss * ss,gfc_expr * expr)8589 walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
8590 {
8591 gfc_ss *tmp_ss, *tail, *array_ss;
8592 gfc_actual_arglist *arg1, *arg2, *arg3;
8593 int sum_dim;
8594 bool scalar_mask = false;
8595
8596 /* The rank of the result will be determined later. */
8597 arg1 = expr->value.function.actual;
8598 arg2 = arg1->next;
8599 arg3 = arg2->next;
8600 gcc_assert (arg3 != NULL);
8601
8602 if (expr->rank == 0)
8603 return ss;
8604
8605 tmp_ss = gfc_ss_terminator;
8606
8607 if (arg3->expr)
8608 {
8609 gfc_ss *mask_ss;
8610
8611 mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
8612 if (mask_ss == tmp_ss)
8613 scalar_mask = 1;
8614
8615 tmp_ss = mask_ss;
8616 }
8617
8618 array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
8619 gcc_assert (array_ss != tmp_ss);
8620
8621 /* Odd thing: If the mask is scalar, it is used by the frontend after
8622 the array (to make an if around the nested loop). Thus it shall
8623 be after array_ss once the gfc_ss list is reversed. */
8624 if (scalar_mask)
8625 tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
8626 else
8627 tmp_ss = array_ss;
8628
8629 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8630 chain. */
8631 sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
8632 tail = nest_loop_dimension (tmp_ss, sum_dim);
8633 tail->next = ss;
8634
8635 return tmp_ss;
8636 }
8637
8638
8639 static gfc_ss *
walk_inline_intrinsic_function(gfc_ss * ss,gfc_expr * expr)8640 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
8641 {
8642
8643 switch (expr->value.function.isym->id)
8644 {
8645 case GFC_ISYM_PRODUCT:
8646 case GFC_ISYM_SUM:
8647 return walk_inline_intrinsic_arith (ss, expr);
8648
8649 case GFC_ISYM_TRANSPOSE:
8650 return walk_inline_intrinsic_transpose (ss, expr);
8651
8652 default:
8653 gcc_unreachable ();
8654 }
8655 gcc_unreachable ();
8656 }
8657
8658
8659 /* This generates code to execute before entering the scalarization loop.
8660 Currently does nothing. */
8661
8662 void
gfc_add_intrinsic_ss_code(gfc_loopinfo * loop ATTRIBUTE_UNUSED,gfc_ss * ss)8663 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
8664 {
8665 switch (ss->info->expr->value.function.isym->id)
8666 {
8667 case GFC_ISYM_UBOUND:
8668 case GFC_ISYM_LBOUND:
8669 case GFC_ISYM_UCOBOUND:
8670 case GFC_ISYM_LCOBOUND:
8671 case GFC_ISYM_THIS_IMAGE:
8672 break;
8673
8674 default:
8675 gcc_unreachable ();
8676 }
8677 }
8678
8679
8680 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8681 are expanded into code inside the scalarization loop. */
8682
8683 static gfc_ss *
gfc_walk_intrinsic_bound(gfc_ss * ss,gfc_expr * expr)8684 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
8685 {
8686 if (expr->value.function.actual->expr->ts.type == BT_CLASS)
8687 gfc_add_class_array_ref (expr->value.function.actual->expr);
8688
8689 /* The two argument version returns a scalar. */
8690 if (expr->value.function.actual->next->expr)
8691 return ss;
8692
8693 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
8694 }
8695
8696
8697 /* Walk an intrinsic array libcall. */
8698
8699 static gfc_ss *
gfc_walk_intrinsic_libfunc(gfc_ss * ss,gfc_expr * expr)8700 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
8701 {
8702 gcc_assert (expr->rank > 0);
8703 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
8704 }
8705
8706
8707 /* Return whether the function call expression EXPR will be expanded
8708 inline by gfc_conv_intrinsic_function. */
8709
8710 bool
gfc_inline_intrinsic_function_p(gfc_expr * expr)8711 gfc_inline_intrinsic_function_p (gfc_expr *expr)
8712 {
8713 gfc_actual_arglist *args;
8714
8715 if (!expr->value.function.isym)
8716 return false;
8717
8718 switch (expr->value.function.isym->id)
8719 {
8720 case GFC_ISYM_PRODUCT:
8721 case GFC_ISYM_SUM:
8722 /* Disable inline expansion if code size matters. */
8723 if (optimize_size)
8724 return false;
8725
8726 args = expr->value.function.actual;
8727 /* We need to be able to subset the SUM argument at compile-time. */
8728 if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
8729 return false;
8730
8731 return true;
8732
8733 case GFC_ISYM_TRANSPOSE:
8734 return true;
8735
8736 default:
8737 return false;
8738 }
8739 }
8740
8741
8742 /* Returns nonzero if the specified intrinsic function call maps directly to
8743 an external library call. Should only be used for functions that return
8744 arrays. */
8745
8746 int
gfc_is_intrinsic_libcall(gfc_expr * expr)8747 gfc_is_intrinsic_libcall (gfc_expr * expr)
8748 {
8749 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
8750 gcc_assert (expr->rank > 0);
8751
8752 if (gfc_inline_intrinsic_function_p (expr))
8753 return 0;
8754
8755 switch (expr->value.function.isym->id)
8756 {
8757 case GFC_ISYM_ALL:
8758 case GFC_ISYM_ANY:
8759 case GFC_ISYM_COUNT:
8760 case GFC_ISYM_JN2:
8761 case GFC_ISYM_IANY:
8762 case GFC_ISYM_IALL:
8763 case GFC_ISYM_IPARITY:
8764 case GFC_ISYM_MATMUL:
8765 case GFC_ISYM_MAXLOC:
8766 case GFC_ISYM_MAXVAL:
8767 case GFC_ISYM_MINLOC:
8768 case GFC_ISYM_MINVAL:
8769 case GFC_ISYM_NORM2:
8770 case GFC_ISYM_PARITY:
8771 case GFC_ISYM_PRODUCT:
8772 case GFC_ISYM_SUM:
8773 case GFC_ISYM_SHAPE:
8774 case GFC_ISYM_SPREAD:
8775 case GFC_ISYM_YN2:
8776 /* Ignore absent optional parameters. */
8777 return 1;
8778
8779 case GFC_ISYM_RESHAPE:
8780 case GFC_ISYM_CSHIFT:
8781 case GFC_ISYM_EOSHIFT:
8782 case GFC_ISYM_PACK:
8783 case GFC_ISYM_UNPACK:
8784 /* Pass absent optional parameters. */
8785 return 2;
8786
8787 default:
8788 return 0;
8789 }
8790 }
8791
8792 /* Walk an intrinsic function. */
8793 gfc_ss *
gfc_walk_intrinsic_function(gfc_ss * ss,gfc_expr * expr,gfc_intrinsic_sym * isym)8794 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
8795 gfc_intrinsic_sym * isym)
8796 {
8797 gcc_assert (isym);
8798
8799 if (isym->elemental)
8800 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8801 NULL, GFC_SS_SCALAR);
8802
8803 if (expr->rank == 0)
8804 return ss;
8805
8806 if (gfc_inline_intrinsic_function_p (expr))
8807 return walk_inline_intrinsic_function (ss, expr);
8808
8809 if (gfc_is_intrinsic_libcall (expr))
8810 return gfc_walk_intrinsic_libfunc (ss, expr);
8811
8812 /* Special cases. */
8813 switch (isym->id)
8814 {
8815 case GFC_ISYM_LBOUND:
8816 case GFC_ISYM_LCOBOUND:
8817 case GFC_ISYM_UBOUND:
8818 case GFC_ISYM_UCOBOUND:
8819 case GFC_ISYM_THIS_IMAGE:
8820 return gfc_walk_intrinsic_bound (ss, expr);
8821
8822 case GFC_ISYM_TRANSFER:
8823 case GFC_ISYM_CAF_GET:
8824 return gfc_walk_intrinsic_libfunc (ss, expr);
8825
8826 default:
8827 /* This probably meant someone forgot to add an intrinsic to the above
8828 list(s) when they implemented it, or something's gone horribly
8829 wrong. */
8830 gcc_unreachable ();
8831 }
8832 }
8833
8834
8835 static tree
conv_co_collective(gfc_code * code)8836 conv_co_collective (gfc_code *code)
8837 {
8838 gfc_se argse;
8839 stmtblock_t block, post_block;
8840 tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
8841 gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
8842
8843 gfc_start_block (&block);
8844 gfc_init_block (&post_block);
8845
8846 if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
8847 {
8848 opr_expr = code->ext.actual->next->expr;
8849 image_idx_expr = code->ext.actual->next->next->expr;
8850 stat_expr = code->ext.actual->next->next->next->expr;
8851 errmsg_expr = code->ext.actual->next->next->next->next->expr;
8852 }
8853 else
8854 {
8855 opr_expr = NULL;
8856 image_idx_expr = code->ext.actual->next->expr;
8857 stat_expr = code->ext.actual->next->next->expr;
8858 errmsg_expr = code->ext.actual->next->next->next->expr;
8859 }
8860
8861 /* stat. */
8862 if (stat_expr)
8863 {
8864 gfc_init_se (&argse, NULL);
8865 gfc_conv_expr (&argse, stat_expr);
8866 gfc_add_block_to_block (&block, &argse.pre);
8867 gfc_add_block_to_block (&post_block, &argse.post);
8868 stat = argse.expr;
8869 if (flag_coarray != GFC_FCOARRAY_SINGLE)
8870 stat = gfc_build_addr_expr (NULL_TREE, stat);
8871 }
8872 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
8873 stat = NULL_TREE;
8874 else
8875 stat = null_pointer_node;
8876
8877 /* Early exit for GFC_FCOARRAY_SINGLE. */
8878 if (flag_coarray == GFC_FCOARRAY_SINGLE)
8879 {
8880 if (stat != NULL_TREE)
8881 gfc_add_modify (&block, stat,
8882 fold_convert (TREE_TYPE (stat), integer_zero_node));
8883 return gfc_finish_block (&block);
8884 }
8885
8886 /* Handle the array. */
8887 gfc_init_se (&argse, NULL);
8888 if (code->ext.actual->expr->rank == 0)
8889 {
8890 symbol_attribute attr;
8891 gfc_clear_attr (&attr);
8892 gfc_init_se (&argse, NULL);
8893 gfc_conv_expr (&argse, code->ext.actual->expr);
8894 gfc_add_block_to_block (&block, &argse.pre);
8895 gfc_add_block_to_block (&post_block, &argse.post);
8896 array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
8897 array = gfc_build_addr_expr (NULL_TREE, array);
8898 }
8899 else
8900 {
8901 argse.want_pointer = 1;
8902 gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
8903 array = argse.expr;
8904 }
8905 gfc_add_block_to_block (&block, &argse.pre);
8906 gfc_add_block_to_block (&post_block, &argse.post);
8907
8908 if (code->ext.actual->expr->ts.type == BT_CHARACTER)
8909 strlen = argse.string_length;
8910 else
8911 strlen = integer_zero_node;
8912
8913 /* image_index. */
8914 if (image_idx_expr)
8915 {
8916 gfc_init_se (&argse, NULL);
8917 gfc_conv_expr (&argse, image_idx_expr);
8918 gfc_add_block_to_block (&block, &argse.pre);
8919 gfc_add_block_to_block (&post_block, &argse.post);
8920 image_index = fold_convert (integer_type_node, argse.expr);
8921 }
8922 else
8923 image_index = integer_zero_node;
8924
8925 /* errmsg. */
8926 if (errmsg_expr)
8927 {
8928 gfc_init_se (&argse, NULL);
8929 gfc_conv_expr (&argse, errmsg_expr);
8930 gfc_add_block_to_block (&block, &argse.pre);
8931 gfc_add_block_to_block (&post_block, &argse.post);
8932 errmsg = argse.expr;
8933 errmsg_len = fold_convert (integer_type_node, argse.string_length);
8934 }
8935 else
8936 {
8937 errmsg = null_pointer_node;
8938 errmsg_len = integer_zero_node;
8939 }
8940
8941 /* Generate the function call. */
8942 switch (code->resolved_isym->id)
8943 {
8944 case GFC_ISYM_CO_BROADCAST:
8945 fndecl = gfor_fndecl_co_broadcast;
8946 break;
8947 case GFC_ISYM_CO_MAX:
8948 fndecl = gfor_fndecl_co_max;
8949 break;
8950 case GFC_ISYM_CO_MIN:
8951 fndecl = gfor_fndecl_co_min;
8952 break;
8953 case GFC_ISYM_CO_REDUCE:
8954 fndecl = gfor_fndecl_co_reduce;
8955 break;
8956 case GFC_ISYM_CO_SUM:
8957 fndecl = gfor_fndecl_co_sum;
8958 break;
8959 default:
8960 gcc_unreachable ();
8961 }
8962
8963 if (code->resolved_isym->id == GFC_ISYM_CO_SUM
8964 || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
8965 fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
8966 image_index, stat, errmsg, errmsg_len);
8967 else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
8968 fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
8969 stat, errmsg, strlen, errmsg_len);
8970 else
8971 {
8972 tree opr, opr_flags;
8973
8974 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8975 int opr_flag_int;
8976 if (gfc_is_proc_ptr_comp (opr_expr))
8977 {
8978 gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
8979 opr_flag_int = sym->attr.dimension
8980 || (sym->ts.type == BT_CHARACTER
8981 && !sym->attr.is_bind_c)
8982 ? GFC_CAF_BYREF : 0;
8983 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
8984 && !sym->attr.is_bind_c
8985 ? GFC_CAF_HIDDENLEN : 0;
8986 opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
8987 }
8988 else
8989 {
8990 opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
8991 ? GFC_CAF_BYREF : 0;
8992 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
8993 && !opr_expr->symtree->n.sym->attr.is_bind_c
8994 ? GFC_CAF_HIDDENLEN : 0;
8995 opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
8996 ? GFC_CAF_ARG_VALUE : 0;
8997 }
8998 opr_flags = build_int_cst (integer_type_node, opr_flag_int);
8999 gfc_conv_expr (&argse, opr_expr);
9000 opr = argse.expr;
9001 fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
9002 image_index, stat, errmsg, strlen, errmsg_len);
9003 }
9004
9005 gfc_add_expr_to_block (&block, fndecl);
9006 gfc_add_block_to_block (&block, &post_block);
9007
9008 return gfc_finish_block (&block);
9009 }
9010
9011
9012 static tree
conv_intrinsic_atomic_op(gfc_code * code)9013 conv_intrinsic_atomic_op (gfc_code *code)
9014 {
9015 gfc_se argse;
9016 tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
9017 stmtblock_t block, post_block;
9018 gfc_expr *atom_expr = code->ext.actual->expr;
9019 gfc_expr *stat_expr;
9020 built_in_function fn;
9021
9022 if (atom_expr->expr_type == EXPR_FUNCTION
9023 && atom_expr->value.function.isym
9024 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9025 atom_expr = atom_expr->value.function.actual->expr;
9026
9027 gfc_start_block (&block);
9028 gfc_init_block (&post_block);
9029
9030 gfc_init_se (&argse, NULL);
9031 argse.want_pointer = 1;
9032 gfc_conv_expr (&argse, atom_expr);
9033 gfc_add_block_to_block (&block, &argse.pre);
9034 gfc_add_block_to_block (&post_block, &argse.post);
9035 atom = argse.expr;
9036
9037 gfc_init_se (&argse, NULL);
9038 if (flag_coarray == GFC_FCOARRAY_LIB
9039 && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
9040 argse.want_pointer = 1;
9041 gfc_conv_expr (&argse, code->ext.actual->next->expr);
9042 gfc_add_block_to_block (&block, &argse.pre);
9043 gfc_add_block_to_block (&post_block, &argse.post);
9044 value = argse.expr;
9045
9046 switch (code->resolved_isym->id)
9047 {
9048 case GFC_ISYM_ATOMIC_ADD:
9049 case GFC_ISYM_ATOMIC_AND:
9050 case GFC_ISYM_ATOMIC_DEF:
9051 case GFC_ISYM_ATOMIC_OR:
9052 case GFC_ISYM_ATOMIC_XOR:
9053 stat_expr = code->ext.actual->next->next->expr;
9054 if (flag_coarray == GFC_FCOARRAY_LIB)
9055 old = null_pointer_node;
9056 break;
9057 default:
9058 gfc_init_se (&argse, NULL);
9059 if (flag_coarray == GFC_FCOARRAY_LIB)
9060 argse.want_pointer = 1;
9061 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
9062 gfc_add_block_to_block (&block, &argse.pre);
9063 gfc_add_block_to_block (&post_block, &argse.post);
9064 old = argse.expr;
9065 stat_expr = code->ext.actual->next->next->next->expr;
9066 }
9067
9068 /* STAT= */
9069 if (stat_expr != NULL)
9070 {
9071 gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
9072 gfc_init_se (&argse, NULL);
9073 if (flag_coarray == GFC_FCOARRAY_LIB)
9074 argse.want_pointer = 1;
9075 gfc_conv_expr_val (&argse, stat_expr);
9076 gfc_add_block_to_block (&block, &argse.pre);
9077 gfc_add_block_to_block (&post_block, &argse.post);
9078 stat = argse.expr;
9079 }
9080 else if (flag_coarray == GFC_FCOARRAY_LIB)
9081 stat = null_pointer_node;
9082
9083 if (flag_coarray == GFC_FCOARRAY_LIB)
9084 {
9085 tree image_index, caf_decl, offset, token;
9086 int op;
9087
9088 switch (code->resolved_isym->id)
9089 {
9090 case GFC_ISYM_ATOMIC_ADD:
9091 case GFC_ISYM_ATOMIC_FETCH_ADD:
9092 op = (int) GFC_CAF_ATOMIC_ADD;
9093 break;
9094 case GFC_ISYM_ATOMIC_AND:
9095 case GFC_ISYM_ATOMIC_FETCH_AND:
9096 op = (int) GFC_CAF_ATOMIC_AND;
9097 break;
9098 case GFC_ISYM_ATOMIC_OR:
9099 case GFC_ISYM_ATOMIC_FETCH_OR:
9100 op = (int) GFC_CAF_ATOMIC_OR;
9101 break;
9102 case GFC_ISYM_ATOMIC_XOR:
9103 case GFC_ISYM_ATOMIC_FETCH_XOR:
9104 op = (int) GFC_CAF_ATOMIC_XOR;
9105 break;
9106 case GFC_ISYM_ATOMIC_DEF:
9107 op = 0; /* Unused. */
9108 break;
9109 default:
9110 gcc_unreachable ();
9111 }
9112
9113 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
9114 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
9115 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
9116
9117 if (gfc_is_coindexed (atom_expr))
9118 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
9119 else
9120 image_index = integer_zero_node;
9121
9122 if (!POINTER_TYPE_P (TREE_TYPE (value)))
9123 {
9124 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
9125 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
9126 value = gfc_build_addr_expr (NULL_TREE, tmp);
9127 }
9128
9129 gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
9130
9131 if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
9132 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
9133 token, offset, image_index, value, stat,
9134 build_int_cst (integer_type_node,
9135 (int) atom_expr->ts.type),
9136 build_int_cst (integer_type_node,
9137 (int) atom_expr->ts.kind));
9138 else
9139 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
9140 build_int_cst (integer_type_node, op),
9141 token, offset, image_index, value, old, stat,
9142 build_int_cst (integer_type_node,
9143 (int) atom_expr->ts.type),
9144 build_int_cst (integer_type_node,
9145 (int) atom_expr->ts.kind));
9146
9147 gfc_add_expr_to_block (&block, tmp);
9148 gfc_add_block_to_block (&block, &post_block);
9149 return gfc_finish_block (&block);
9150 }
9151
9152
9153 switch (code->resolved_isym->id)
9154 {
9155 case GFC_ISYM_ATOMIC_ADD:
9156 case GFC_ISYM_ATOMIC_FETCH_ADD:
9157 fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
9158 break;
9159 case GFC_ISYM_ATOMIC_AND:
9160 case GFC_ISYM_ATOMIC_FETCH_AND:
9161 fn = BUILT_IN_ATOMIC_FETCH_AND_N;
9162 break;
9163 case GFC_ISYM_ATOMIC_DEF:
9164 fn = BUILT_IN_ATOMIC_STORE_N;
9165 break;
9166 case GFC_ISYM_ATOMIC_OR:
9167 case GFC_ISYM_ATOMIC_FETCH_OR:
9168 fn = BUILT_IN_ATOMIC_FETCH_OR_N;
9169 break;
9170 case GFC_ISYM_ATOMIC_XOR:
9171 case GFC_ISYM_ATOMIC_FETCH_XOR:
9172 fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
9173 break;
9174 default:
9175 gcc_unreachable ();
9176 }
9177
9178 tmp = TREE_TYPE (TREE_TYPE (atom));
9179 fn = (built_in_function) ((int) fn
9180 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
9181 + 1);
9182 tmp = builtin_decl_explicit (fn);
9183 tree itype = TREE_TYPE (TREE_TYPE (atom));
9184 tmp = builtin_decl_explicit (fn);
9185
9186 switch (code->resolved_isym->id)
9187 {
9188 case GFC_ISYM_ATOMIC_ADD:
9189 case GFC_ISYM_ATOMIC_AND:
9190 case GFC_ISYM_ATOMIC_DEF:
9191 case GFC_ISYM_ATOMIC_OR:
9192 case GFC_ISYM_ATOMIC_XOR:
9193 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
9194 fold_convert (itype, value),
9195 build_int_cst (NULL, MEMMODEL_RELAXED));
9196 gfc_add_expr_to_block (&block, tmp);
9197 break;
9198 default:
9199 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
9200 fold_convert (itype, value),
9201 build_int_cst (NULL, MEMMODEL_RELAXED));
9202 gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
9203 break;
9204 }
9205
9206 if (stat != NULL_TREE)
9207 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
9208 gfc_add_block_to_block (&block, &post_block);
9209 return gfc_finish_block (&block);
9210 }
9211
9212
9213 static tree
conv_intrinsic_atomic_ref(gfc_code * code)9214 conv_intrinsic_atomic_ref (gfc_code *code)
9215 {
9216 gfc_se argse;
9217 tree tmp, atom, value, stat = NULL_TREE;
9218 stmtblock_t block, post_block;
9219 built_in_function fn;
9220 gfc_expr *atom_expr = code->ext.actual->next->expr;
9221
9222 if (atom_expr->expr_type == EXPR_FUNCTION
9223 && atom_expr->value.function.isym
9224 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9225 atom_expr = atom_expr->value.function.actual->expr;
9226
9227 gfc_start_block (&block);
9228 gfc_init_block (&post_block);
9229 gfc_init_se (&argse, NULL);
9230 argse.want_pointer = 1;
9231 gfc_conv_expr (&argse, atom_expr);
9232 gfc_add_block_to_block (&block, &argse.pre);
9233 gfc_add_block_to_block (&post_block, &argse.post);
9234 atom = argse.expr;
9235
9236 gfc_init_se (&argse, NULL);
9237 if (flag_coarray == GFC_FCOARRAY_LIB
9238 && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
9239 argse.want_pointer = 1;
9240 gfc_conv_expr (&argse, code->ext.actual->expr);
9241 gfc_add_block_to_block (&block, &argse.pre);
9242 gfc_add_block_to_block (&post_block, &argse.post);
9243 value = argse.expr;
9244
9245 /* STAT= */
9246 if (code->ext.actual->next->next->expr != NULL)
9247 {
9248 gcc_assert (code->ext.actual->next->next->expr->expr_type
9249 == EXPR_VARIABLE);
9250 gfc_init_se (&argse, NULL);
9251 if (flag_coarray == GFC_FCOARRAY_LIB)
9252 argse.want_pointer = 1;
9253 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
9254 gfc_add_block_to_block (&block, &argse.pre);
9255 gfc_add_block_to_block (&post_block, &argse.post);
9256 stat = argse.expr;
9257 }
9258 else if (flag_coarray == GFC_FCOARRAY_LIB)
9259 stat = null_pointer_node;
9260
9261 if (flag_coarray == GFC_FCOARRAY_LIB)
9262 {
9263 tree image_index, caf_decl, offset, token;
9264 tree orig_value = NULL_TREE, vardecl = NULL_TREE;
9265
9266 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
9267 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
9268 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
9269
9270 if (gfc_is_coindexed (atom_expr))
9271 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
9272 else
9273 image_index = integer_zero_node;
9274
9275 gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
9276
9277 /* Different type, need type conversion. */
9278 if (!POINTER_TYPE_P (TREE_TYPE (value)))
9279 {
9280 vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
9281 orig_value = value;
9282 value = gfc_build_addr_expr (NULL_TREE, vardecl);
9283 }
9284
9285 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
9286 token, offset, image_index, value, stat,
9287 build_int_cst (integer_type_node,
9288 (int) atom_expr->ts.type),
9289 build_int_cst (integer_type_node,
9290 (int) atom_expr->ts.kind));
9291 gfc_add_expr_to_block (&block, tmp);
9292 if (vardecl != NULL_TREE)
9293 gfc_add_modify (&block, orig_value,
9294 fold_convert (TREE_TYPE (orig_value), vardecl));
9295 gfc_add_block_to_block (&block, &post_block);
9296 return gfc_finish_block (&block);
9297 }
9298
9299 tmp = TREE_TYPE (TREE_TYPE (atom));
9300 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
9301 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
9302 + 1);
9303 tmp = builtin_decl_explicit (fn);
9304 tmp = build_call_expr_loc (input_location, tmp, 2, atom,
9305 build_int_cst (integer_type_node,
9306 MEMMODEL_RELAXED));
9307 gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
9308
9309 if (stat != NULL_TREE)
9310 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
9311 gfc_add_block_to_block (&block, &post_block);
9312 return gfc_finish_block (&block);
9313 }
9314
9315
9316 static tree
conv_intrinsic_atomic_cas(gfc_code * code)9317 conv_intrinsic_atomic_cas (gfc_code *code)
9318 {
9319 gfc_se argse;
9320 tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
9321 stmtblock_t block, post_block;
9322 built_in_function fn;
9323 gfc_expr *atom_expr = code->ext.actual->expr;
9324
9325 if (atom_expr->expr_type == EXPR_FUNCTION
9326 && atom_expr->value.function.isym
9327 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9328 atom_expr = atom_expr->value.function.actual->expr;
9329
9330 gfc_init_block (&block);
9331 gfc_init_block (&post_block);
9332 gfc_init_se (&argse, NULL);
9333 argse.want_pointer = 1;
9334 gfc_conv_expr (&argse, atom_expr);
9335 atom = argse.expr;
9336
9337 gfc_init_se (&argse, NULL);
9338 if (flag_coarray == GFC_FCOARRAY_LIB)
9339 argse.want_pointer = 1;
9340 gfc_conv_expr (&argse, code->ext.actual->next->expr);
9341 gfc_add_block_to_block (&block, &argse.pre);
9342 gfc_add_block_to_block (&post_block, &argse.post);
9343 old = argse.expr;
9344
9345 gfc_init_se (&argse, NULL);
9346 if (flag_coarray == GFC_FCOARRAY_LIB)
9347 argse.want_pointer = 1;
9348 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
9349 gfc_add_block_to_block (&block, &argse.pre);
9350 gfc_add_block_to_block (&post_block, &argse.post);
9351 comp = argse.expr;
9352
9353 gfc_init_se (&argse, NULL);
9354 if (flag_coarray == GFC_FCOARRAY_LIB
9355 && code->ext.actual->next->next->next->expr->ts.kind
9356 == atom_expr->ts.kind)
9357 argse.want_pointer = 1;
9358 gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
9359 gfc_add_block_to_block (&block, &argse.pre);
9360 gfc_add_block_to_block (&post_block, &argse.post);
9361 new_val = argse.expr;
9362
9363 /* STAT= */
9364 if (code->ext.actual->next->next->next->next->expr != NULL)
9365 {
9366 gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
9367 == EXPR_VARIABLE);
9368 gfc_init_se (&argse, NULL);
9369 if (flag_coarray == GFC_FCOARRAY_LIB)
9370 argse.want_pointer = 1;
9371 gfc_conv_expr_val (&argse,
9372 code->ext.actual->next->next->next->next->expr);
9373 gfc_add_block_to_block (&block, &argse.pre);
9374 gfc_add_block_to_block (&post_block, &argse.post);
9375 stat = argse.expr;
9376 }
9377 else if (flag_coarray == GFC_FCOARRAY_LIB)
9378 stat = null_pointer_node;
9379
9380 if (flag_coarray == GFC_FCOARRAY_LIB)
9381 {
9382 tree image_index, caf_decl, offset, token;
9383
9384 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
9385 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
9386 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
9387
9388 if (gfc_is_coindexed (atom_expr))
9389 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
9390 else
9391 image_index = integer_zero_node;
9392
9393 if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
9394 {
9395 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
9396 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
9397 new_val = gfc_build_addr_expr (NULL_TREE, tmp);
9398 }
9399
9400 /* Convert a constant to a pointer. */
9401 if (!POINTER_TYPE_P (TREE_TYPE (comp)))
9402 {
9403 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
9404 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
9405 comp = gfc_build_addr_expr (NULL_TREE, tmp);
9406 }
9407
9408 gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
9409
9410 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
9411 token, offset, image_index, old, comp, new_val,
9412 stat, build_int_cst (integer_type_node,
9413 (int) atom_expr->ts.type),
9414 build_int_cst (integer_type_node,
9415 (int) atom_expr->ts.kind));
9416 gfc_add_expr_to_block (&block, tmp);
9417 gfc_add_block_to_block (&block, &post_block);
9418 return gfc_finish_block (&block);
9419 }
9420
9421 tmp = TREE_TYPE (TREE_TYPE (atom));
9422 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9423 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
9424 + 1);
9425 tmp = builtin_decl_explicit (fn);
9426
9427 gfc_add_modify (&block, old, comp);
9428 tmp = build_call_expr_loc (input_location, tmp, 6, atom,
9429 gfc_build_addr_expr (NULL, old),
9430 fold_convert (TREE_TYPE (old), new_val),
9431 boolean_false_node,
9432 build_int_cst (NULL, MEMMODEL_RELAXED),
9433 build_int_cst (NULL, MEMMODEL_RELAXED));
9434 gfc_add_expr_to_block (&block, tmp);
9435
9436 if (stat != NULL_TREE)
9437 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
9438 gfc_add_block_to_block (&block, &post_block);
9439 return gfc_finish_block (&block);
9440 }
9441
9442 static tree
conv_intrinsic_event_query(gfc_code * code)9443 conv_intrinsic_event_query (gfc_code *code)
9444 {
9445 gfc_se se, argse;
9446 tree stat = NULL_TREE, stat2 = NULL_TREE;
9447 tree count = NULL_TREE, count2 = NULL_TREE;
9448
9449 gfc_expr *event_expr = code->ext.actual->expr;
9450
9451 if (code->ext.actual->next->next->expr)
9452 {
9453 gcc_assert (code->ext.actual->next->next->expr->expr_type
9454 == EXPR_VARIABLE);
9455 gfc_init_se (&argse, NULL);
9456 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
9457 stat = argse.expr;
9458 }
9459 else if (flag_coarray == GFC_FCOARRAY_LIB)
9460 stat = null_pointer_node;
9461
9462 if (code->ext.actual->next->expr)
9463 {
9464 gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
9465 gfc_init_se (&argse, NULL);
9466 gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
9467 count = argse.expr;
9468 }
9469
9470 gfc_start_block (&se.pre);
9471 if (flag_coarray == GFC_FCOARRAY_LIB)
9472 {
9473 tree tmp, token, image_index;
9474 tree index = size_zero_node;
9475
9476 if (event_expr->expr_type == EXPR_FUNCTION
9477 && event_expr->value.function.isym
9478 && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9479 event_expr = event_expr->value.function.actual->expr;
9480
9481 tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
9482
9483 if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
9484 || event_expr->symtree->n.sym->ts.u.derived->from_intmod
9485 != INTMOD_ISO_FORTRAN_ENV
9486 || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
9487 != ISOFORTRAN_EVENT_TYPE)
9488 {
9489 gfc_error ("Sorry, the event component of derived type at %L is not "
9490 "yet supported", &event_expr->where);
9491 return NULL_TREE;
9492 }
9493
9494 if (gfc_is_coindexed (event_expr))
9495 {
9496 gfc_error ("The event variable at %L shall not be coindexed ",
9497 &event_expr->where);
9498 return NULL_TREE;
9499 }
9500
9501 image_index = integer_zero_node;
9502
9503 gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, event_expr);
9504
9505 /* For arrays, obtain the array index. */
9506 if (gfc_expr_attr (event_expr).dimension)
9507 {
9508 tree desc, tmp, extent, lbound, ubound;
9509 gfc_array_ref *ar, ar2;
9510 int i;
9511
9512 /* TODO: Extend this, once DT components are supported. */
9513 ar = &event_expr->ref->u.ar;
9514 ar2 = *ar;
9515 memset (ar, '\0', sizeof (*ar));
9516 ar->as = ar2.as;
9517 ar->type = AR_FULL;
9518
9519 gfc_init_se (&argse, NULL);
9520 argse.descriptor_only = 1;
9521 gfc_conv_expr_descriptor (&argse, event_expr);
9522 gfc_add_block_to_block (&se.pre, &argse.pre);
9523 desc = argse.expr;
9524 *ar = ar2;
9525
9526 extent = integer_one_node;
9527 for (i = 0; i < ar->dimen; i++)
9528 {
9529 gfc_init_se (&argse, NULL);
9530 gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
9531 gfc_add_block_to_block (&argse.pre, &argse.pre);
9532 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
9533 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9534 integer_type_node, argse.expr,
9535 fold_convert(integer_type_node, lbound));
9536 tmp = fold_build2_loc (input_location, MULT_EXPR,
9537 integer_type_node, extent, tmp);
9538 index = fold_build2_loc (input_location, PLUS_EXPR,
9539 integer_type_node, index, tmp);
9540 if (i < ar->dimen - 1)
9541 {
9542 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
9543 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9544 tmp = fold_convert (integer_type_node, tmp);
9545 extent = fold_build2_loc (input_location, MULT_EXPR,
9546 integer_type_node, extent, tmp);
9547 }
9548 }
9549 }
9550
9551 if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
9552 {
9553 count2 = count;
9554 count = gfc_create_var (integer_type_node, "count");
9555 }
9556
9557 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
9558 {
9559 stat2 = stat;
9560 stat = gfc_create_var (integer_type_node, "stat");
9561 }
9562
9563 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
9564 token, index, image_index, count
9565 ? gfc_build_addr_expr (NULL, count) : count,
9566 stat != null_pointer_node
9567 ? gfc_build_addr_expr (NULL, stat) : stat);
9568 gfc_add_expr_to_block (&se.pre, tmp);
9569
9570 if (count2 != NULL_TREE)
9571 gfc_add_modify (&se.pre, count2,
9572 fold_convert (TREE_TYPE (count2), count));
9573
9574 if (stat2 != NULL_TREE)
9575 gfc_add_modify (&se.pre, stat2,
9576 fold_convert (TREE_TYPE (stat2), stat));
9577
9578 return gfc_finish_block (&se.pre);
9579 }
9580
9581 gfc_init_se (&argse, NULL);
9582 gfc_conv_expr_val (&argse, code->ext.actual->expr);
9583 gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
9584
9585 if (stat != NULL_TREE)
9586 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
9587
9588 return gfc_finish_block (&se.pre);
9589 }
9590
9591 static tree
conv_intrinsic_move_alloc(gfc_code * code)9592 conv_intrinsic_move_alloc (gfc_code *code)
9593 {
9594 stmtblock_t block;
9595 gfc_expr *from_expr, *to_expr;
9596 gfc_expr *to_expr2, *from_expr2 = NULL;
9597 gfc_se from_se, to_se;
9598 tree tmp;
9599 bool coarray;
9600
9601 gfc_start_block (&block);
9602
9603 from_expr = code->ext.actual->expr;
9604 to_expr = code->ext.actual->next->expr;
9605
9606 gfc_init_se (&from_se, NULL);
9607 gfc_init_se (&to_se, NULL);
9608
9609 gcc_assert (from_expr->ts.type != BT_CLASS
9610 || to_expr->ts.type == BT_CLASS);
9611 coarray = gfc_get_corank (from_expr) != 0;
9612
9613 if (from_expr->rank == 0 && !coarray)
9614 {
9615 if (from_expr->ts.type != BT_CLASS)
9616 from_expr2 = from_expr;
9617 else
9618 {
9619 from_expr2 = gfc_copy_expr (from_expr);
9620 gfc_add_data_component (from_expr2);
9621 }
9622
9623 if (to_expr->ts.type != BT_CLASS)
9624 to_expr2 = to_expr;
9625 else
9626 {
9627 to_expr2 = gfc_copy_expr (to_expr);
9628 gfc_add_data_component (to_expr2);
9629 }
9630
9631 from_se.want_pointer = 1;
9632 to_se.want_pointer = 1;
9633 gfc_conv_expr (&from_se, from_expr2);
9634 gfc_conv_expr (&to_se, to_expr2);
9635 gfc_add_block_to_block (&block, &from_se.pre);
9636 gfc_add_block_to_block (&block, &to_se.pre);
9637
9638 /* Deallocate "to". */
9639 tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
9640 to_expr, to_expr->ts);
9641 gfc_add_expr_to_block (&block, tmp);
9642
9643 /* Assign (_data) pointers. */
9644 gfc_add_modify_loc (input_location, &block, to_se.expr,
9645 fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
9646
9647 /* Set "from" to NULL. */
9648 gfc_add_modify_loc (input_location, &block, from_se.expr,
9649 fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
9650
9651 gfc_add_block_to_block (&block, &from_se.post);
9652 gfc_add_block_to_block (&block, &to_se.post);
9653
9654 /* Set _vptr. */
9655 if (to_expr->ts.type == BT_CLASS)
9656 {
9657 gfc_symbol *vtab;
9658
9659 gfc_free_expr (to_expr2);
9660 gfc_init_se (&to_se, NULL);
9661 to_se.want_pointer = 1;
9662 gfc_add_vptr_component (to_expr);
9663 gfc_conv_expr (&to_se, to_expr);
9664
9665 if (from_expr->ts.type == BT_CLASS)
9666 {
9667 if (UNLIMITED_POLY (from_expr))
9668 vtab = NULL;
9669 else
9670 {
9671 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
9672 gcc_assert (vtab);
9673 }
9674
9675 gfc_free_expr (from_expr2);
9676 gfc_init_se (&from_se, NULL);
9677 from_se.want_pointer = 1;
9678 gfc_add_vptr_component (from_expr);
9679 gfc_conv_expr (&from_se, from_expr);
9680 gfc_add_modify_loc (input_location, &block, to_se.expr,
9681 fold_convert (TREE_TYPE (to_se.expr),
9682 from_se.expr));
9683
9684 /* Reset _vptr component to declared type. */
9685 if (vtab == NULL)
9686 /* Unlimited polymorphic. */
9687 gfc_add_modify_loc (input_location, &block, from_se.expr,
9688 fold_convert (TREE_TYPE (from_se.expr),
9689 null_pointer_node));
9690 else
9691 {
9692 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
9693 gfc_add_modify_loc (input_location, &block, from_se.expr,
9694 fold_convert (TREE_TYPE (from_se.expr), tmp));
9695 }
9696 }
9697 else
9698 {
9699 vtab = gfc_find_vtab (&from_expr->ts);
9700 gcc_assert (vtab);
9701 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
9702 gfc_add_modify_loc (input_location, &block, to_se.expr,
9703 fold_convert (TREE_TYPE (to_se.expr), tmp));
9704 }
9705 }
9706
9707 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
9708 {
9709 gfc_add_modify_loc (input_location, &block, to_se.string_length,
9710 fold_convert (TREE_TYPE (to_se.string_length),
9711 from_se.string_length));
9712 if (from_expr->ts.deferred)
9713 gfc_add_modify_loc (input_location, &block, from_se.string_length,
9714 build_int_cst (TREE_TYPE (from_se.string_length), 0));
9715 }
9716
9717 return gfc_finish_block (&block);
9718 }
9719
9720 /* Update _vptr component. */
9721 if (to_expr->ts.type == BT_CLASS)
9722 {
9723 gfc_symbol *vtab;
9724
9725 to_se.want_pointer = 1;
9726 to_expr2 = gfc_copy_expr (to_expr);
9727 gfc_add_vptr_component (to_expr2);
9728 gfc_conv_expr (&to_se, to_expr2);
9729
9730 if (from_expr->ts.type == BT_CLASS)
9731 {
9732 if (UNLIMITED_POLY (from_expr))
9733 vtab = NULL;
9734 else
9735 {
9736 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
9737 gcc_assert (vtab);
9738 }
9739
9740 from_se.want_pointer = 1;
9741 from_expr2 = gfc_copy_expr (from_expr);
9742 gfc_add_vptr_component (from_expr2);
9743 gfc_conv_expr (&from_se, from_expr2);
9744 gfc_add_modify_loc (input_location, &block, to_se.expr,
9745 fold_convert (TREE_TYPE (to_se.expr),
9746 from_se.expr));
9747
9748 /* Reset _vptr component to declared type. */
9749 if (vtab == NULL)
9750 /* Unlimited polymorphic. */
9751 gfc_add_modify_loc (input_location, &block, from_se.expr,
9752 fold_convert (TREE_TYPE (from_se.expr),
9753 null_pointer_node));
9754 else
9755 {
9756 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
9757 gfc_add_modify_loc (input_location, &block, from_se.expr,
9758 fold_convert (TREE_TYPE (from_se.expr), tmp));
9759 }
9760 }
9761 else
9762 {
9763 vtab = gfc_find_vtab (&from_expr->ts);
9764 gcc_assert (vtab);
9765 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
9766 gfc_add_modify_loc (input_location, &block, to_se.expr,
9767 fold_convert (TREE_TYPE (to_se.expr), tmp));
9768 }
9769
9770 gfc_free_expr (to_expr2);
9771 gfc_init_se (&to_se, NULL);
9772
9773 if (from_expr->ts.type == BT_CLASS)
9774 {
9775 gfc_free_expr (from_expr2);
9776 gfc_init_se (&from_se, NULL);
9777 }
9778 }
9779
9780
9781 /* Deallocate "to". */
9782 if (from_expr->rank == 0)
9783 {
9784 to_se.want_coarray = 1;
9785 from_se.want_coarray = 1;
9786 }
9787 gfc_conv_expr_descriptor (&to_se, to_expr);
9788 gfc_conv_expr_descriptor (&from_se, from_expr);
9789
9790 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9791 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9792 if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
9793 {
9794 tree cond;
9795
9796 tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
9797 NULL_TREE, NULL_TREE, true, to_expr,
9798 true);
9799 gfc_add_expr_to_block (&block, tmp);
9800
9801 tmp = gfc_conv_descriptor_data_get (to_se.expr);
9802 cond = fold_build2_loc (input_location, EQ_EXPR,
9803 boolean_type_node, tmp,
9804 fold_convert (TREE_TYPE (tmp),
9805 null_pointer_node));
9806 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
9807 3, null_pointer_node, null_pointer_node,
9808 build_int_cst (integer_type_node, 0));
9809
9810 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
9811 tmp, build_empty_stmt (input_location));
9812 gfc_add_expr_to_block (&block, tmp);
9813 }
9814 else
9815 {
9816 if (to_expr->ts.type == BT_DERIVED
9817 && to_expr->ts.u.derived->attr.alloc_comp)
9818 {
9819 tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
9820 to_se.expr, to_expr->rank);
9821 gfc_add_expr_to_block (&block, tmp);
9822 }
9823
9824 tmp = gfc_conv_descriptor_data_get (to_se.expr);
9825 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
9826 NULL_TREE, true, to_expr, false);
9827 gfc_add_expr_to_block (&block, tmp);
9828 }
9829
9830 /* Move the pointer and update the array descriptor data. */
9831 gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
9832
9833 /* Set "from" to NULL. */
9834 tmp = gfc_conv_descriptor_data_get (from_se.expr);
9835 gfc_add_modify_loc (input_location, &block, tmp,
9836 fold_convert (TREE_TYPE (tmp), null_pointer_node));
9837
9838
9839 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
9840 {
9841 gfc_add_modify_loc (input_location, &block, to_se.string_length,
9842 fold_convert (TREE_TYPE (to_se.string_length),
9843 from_se.string_length));
9844 if (from_expr->ts.deferred)
9845 gfc_add_modify_loc (input_location, &block, from_se.string_length,
9846 build_int_cst (TREE_TYPE (from_se.string_length), 0));
9847 }
9848
9849 return gfc_finish_block (&block);
9850 }
9851
9852
9853 tree
gfc_conv_intrinsic_subroutine(gfc_code * code)9854 gfc_conv_intrinsic_subroutine (gfc_code *code)
9855 {
9856 tree res;
9857
9858 gcc_assert (code->resolved_isym);
9859
9860 switch (code->resolved_isym->id)
9861 {
9862 case GFC_ISYM_MOVE_ALLOC:
9863 res = conv_intrinsic_move_alloc (code);
9864 break;
9865
9866 case GFC_ISYM_ATOMIC_CAS:
9867 res = conv_intrinsic_atomic_cas (code);
9868 break;
9869
9870 case GFC_ISYM_ATOMIC_ADD:
9871 case GFC_ISYM_ATOMIC_AND:
9872 case GFC_ISYM_ATOMIC_DEF:
9873 case GFC_ISYM_ATOMIC_OR:
9874 case GFC_ISYM_ATOMIC_XOR:
9875 case GFC_ISYM_ATOMIC_FETCH_ADD:
9876 case GFC_ISYM_ATOMIC_FETCH_AND:
9877 case GFC_ISYM_ATOMIC_FETCH_OR:
9878 case GFC_ISYM_ATOMIC_FETCH_XOR:
9879 res = conv_intrinsic_atomic_op (code);
9880 break;
9881
9882 case GFC_ISYM_ATOMIC_REF:
9883 res = conv_intrinsic_atomic_ref (code);
9884 break;
9885
9886 case GFC_ISYM_EVENT_QUERY:
9887 res = conv_intrinsic_event_query (code);
9888 break;
9889
9890 case GFC_ISYM_C_F_POINTER:
9891 case GFC_ISYM_C_F_PROCPOINTER:
9892 res = conv_isocbinding_subroutine (code);
9893 break;
9894
9895 case GFC_ISYM_CAF_SEND:
9896 res = conv_caf_send (code);
9897 break;
9898
9899 case GFC_ISYM_CO_BROADCAST:
9900 case GFC_ISYM_CO_MIN:
9901 case GFC_ISYM_CO_MAX:
9902 case GFC_ISYM_CO_REDUCE:
9903 case GFC_ISYM_CO_SUM:
9904 res = conv_co_collective (code);
9905 break;
9906
9907 case GFC_ISYM_FREE:
9908 res = conv_intrinsic_free (code);
9909 break;
9910
9911 case GFC_ISYM_SYSTEM_CLOCK:
9912 res = conv_intrinsic_system_clock (code);
9913 break;
9914
9915 default:
9916 res = NULL_TREE;
9917 break;
9918 }
9919
9920 return res;
9921 }
9922
9923 #include "gt-fortran-trans-intrinsic.h"
9924