1 /* Intrinsic translation
2 Copyright (C) 2002-2021 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 "memmodel.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
29 #include "tree.h"
30 #include "gfortran.h"
31 #include "trans.h"
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "internal-fn.h"
35 #include "tree-nested.h"
36 #include "stor-layout.h"
37 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "arith.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "dependency.h" /* For CAF array alias analysis. */
43 #include "attribs.h"
44
45 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
46
47 /* This maps Fortran intrinsic math functions to external library or GCC
48 builtin functions. */
49 typedef struct GTY(()) gfc_intrinsic_map_t {
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
52 enum gfc_isym_id id;
53
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function float_built_in;
57 enum built_in_function double_built_in;
58 enum built_in_function long_double_built_in;
59 enum built_in_function complex_float_built_in;
60 enum built_in_function complex_double_built_in;
61 enum built_in_function complex_long_double_built_in;
62
63 /* True if the naming pattern is to prepend "c" for complex and
64 append "f" for kind=4. False if the naming pattern is to
65 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 bool libm_name;
67
68 /* True if a complex version of the function exists. */
69 bool complex_available;
70
71 /* True if the function should be marked const. */
72 bool is_constant;
73
74 /* The base library name of this function. */
75 const char *name;
76
77 /* Cache decls created for the various operand types. */
78 tree real4_decl;
79 tree real8_decl;
80 tree real10_decl;
81 tree real16_decl;
82 tree complex4_decl;
83 tree complex8_decl;
84 tree complex10_decl;
85 tree complex16_decl;
86 }
87 gfc_intrinsic_map_t;
88
89 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
90 defines complex variants of all of the entries in mathbuiltins.def
91 except for atan2. */
92 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
93 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
94 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
95 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
96 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
97
98 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
99 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
100 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
101 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
102 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
103
104 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
105 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
106 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
108 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
109
110 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
111 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
112 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
113 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
114 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
115
116 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
117 {
118 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
119 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
120 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
121 #include "mathbuiltins.def"
122
123 /* Functions in libgfortran. */
124 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
125 LIB_FUNCTION (SIND, "sind", false),
126 LIB_FUNCTION (COSD, "cosd", false),
127 LIB_FUNCTION (TAND, "tand", false),
128
129 /* End the list. */
130 LIB_FUNCTION (NONE, NULL, false)
131
132 };
133 #undef OTHER_BUILTIN
134 #undef LIB_FUNCTION
135 #undef DEFINE_MATH_BUILTIN
136 #undef DEFINE_MATH_BUILTIN_C
137
138
139 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
140
141
142 /* Find the correct variant of a given builtin from its argument. */
143 static tree
builtin_decl_for_precision(enum built_in_function base_built_in,int precision)144 builtin_decl_for_precision (enum built_in_function base_built_in,
145 int precision)
146 {
147 enum built_in_function i = END_BUILTINS;
148
149 gfc_intrinsic_map_t *m;
150 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
151 ;
152
153 if (precision == TYPE_PRECISION (float_type_node))
154 i = m->float_built_in;
155 else if (precision == TYPE_PRECISION (double_type_node))
156 i = m->double_built_in;
157 else if (precision == TYPE_PRECISION (long_double_type_node))
158 i = m->long_double_built_in;
159 else if (precision == TYPE_PRECISION (gfc_float128_type_node))
160 {
161 /* Special treatment, because it is not exactly a built-in, but
162 a library function. */
163 return m->real16_decl;
164 }
165
166 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
167 }
168
169
170 tree
gfc_builtin_decl_for_float_kind(enum built_in_function double_built_in,int kind)171 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
172 int kind)
173 {
174 int i = gfc_validate_kind (BT_REAL, kind, false);
175
176 if (gfc_real_kinds[i].c_float128)
177 {
178 /* For __float128, the story is a bit different, because we return
179 a decl to a library function rather than a built-in. */
180 gfc_intrinsic_map_t *m;
181 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
182 ;
183
184 return m->real16_decl;
185 }
186
187 return builtin_decl_for_precision (double_built_in,
188 gfc_real_kinds[i].mode_precision);
189 }
190
191
192 /* Evaluate the arguments to an intrinsic function. The value
193 of NARGS may be less than the actual number of arguments in EXPR
194 to allow optional "KIND" arguments that are not included in the
195 generated code to be ignored. */
196
197 static void
gfc_conv_intrinsic_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)198 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
199 tree *argarray, int nargs)
200 {
201 gfc_actual_arglist *actual;
202 gfc_expr *e;
203 gfc_intrinsic_arg *formal;
204 gfc_se argse;
205 int curr_arg;
206
207 formal = expr->value.function.isym->formal;
208 actual = expr->value.function.actual;
209
210 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
211 actual = actual->next,
212 formal = formal ? formal->next : NULL)
213 {
214 gcc_assert (actual);
215 e = actual->expr;
216 /* Skip omitted optional arguments. */
217 if (!e)
218 {
219 --curr_arg;
220 continue;
221 }
222
223 /* Evaluate the parameter. This will substitute scalarized
224 references automatically. */
225 gfc_init_se (&argse, se);
226
227 if (e->ts.type == BT_CHARACTER)
228 {
229 gfc_conv_expr (&argse, e);
230 gfc_conv_string_parameter (&argse);
231 argarray[curr_arg++] = argse.string_length;
232 gcc_assert (curr_arg < nargs);
233 }
234 else
235 gfc_conv_expr_val (&argse, e);
236
237 /* If an optional argument is itself an optional dummy argument,
238 check its presence and substitute a null if absent. */
239 if (e->expr_type == EXPR_VARIABLE
240 && e->symtree->n.sym->attr.optional
241 && formal
242 && formal->optional)
243 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
244
245 gfc_add_block_to_block (&se->pre, &argse.pre);
246 gfc_add_block_to_block (&se->post, &argse.post);
247 argarray[curr_arg] = argse.expr;
248 }
249 }
250
251 /* Count the number of actual arguments to the intrinsic function EXPR
252 including any "hidden" string length arguments. */
253
254 static unsigned int
gfc_intrinsic_argument_list_length(gfc_expr * expr)255 gfc_intrinsic_argument_list_length (gfc_expr *expr)
256 {
257 int n = 0;
258 gfc_actual_arglist *actual;
259
260 for (actual = expr->value.function.actual; actual; actual = actual->next)
261 {
262 if (!actual->expr)
263 continue;
264
265 if (actual->expr->ts.type == BT_CHARACTER)
266 n += 2;
267 else
268 n++;
269 }
270
271 return n;
272 }
273
274
275 /* Conversions between different types are output by the frontend as
276 intrinsic functions. We implement these directly with inline code. */
277
278 static void
gfc_conv_intrinsic_conversion(gfc_se * se,gfc_expr * expr)279 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
280 {
281 tree type;
282 tree *args;
283 int nargs;
284
285 nargs = gfc_intrinsic_argument_list_length (expr);
286 args = XALLOCAVEC (tree, nargs);
287
288 /* Evaluate all the arguments passed. Whilst we're only interested in the
289 first one here, there are other parts of the front-end that assume this
290 and will trigger an ICE if it's not the case. */
291 type = gfc_typenode_for_spec (&expr->ts);
292 gcc_assert (expr->value.function.actual->expr);
293 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
294
295 /* Conversion between character kinds involves a call to a library
296 function. */
297 if (expr->ts.type == BT_CHARACTER)
298 {
299 tree fndecl, var, addr, tmp;
300
301 if (expr->ts.kind == 1
302 && expr->value.function.actual->expr->ts.kind == 4)
303 fndecl = gfor_fndecl_convert_char4_to_char1;
304 else if (expr->ts.kind == 4
305 && expr->value.function.actual->expr->ts.kind == 1)
306 fndecl = gfor_fndecl_convert_char1_to_char4;
307 else
308 gcc_unreachable ();
309
310 /* Create the variable storing the converted value. */
311 type = gfc_get_pchar_type (expr->ts.kind);
312 var = gfc_create_var (type, "str");
313 addr = gfc_build_addr_expr (build_pointer_type (type), var);
314
315 /* Call the library function that will perform the conversion. */
316 gcc_assert (nargs >= 2);
317 tmp = build_call_expr_loc (input_location,
318 fndecl, 3, addr, args[0], args[1]);
319 gfc_add_expr_to_block (&se->pre, tmp);
320
321 /* Free the temporary afterwards. */
322 tmp = gfc_call_free (var);
323 gfc_add_expr_to_block (&se->post, tmp);
324
325 se->expr = var;
326 se->string_length = args[0];
327
328 return;
329 }
330
331 /* Conversion from complex to non-complex involves taking the real
332 component of the value. */
333 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
334 && expr->ts.type != BT_COMPLEX)
335 {
336 tree artype;
337
338 artype = TREE_TYPE (TREE_TYPE (args[0]));
339 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
340 args[0]);
341 }
342
343 se->expr = convert (type, args[0]);
344 }
345
346 /* This is needed because the gcc backend only implements
347 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
348 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
349 Similarly for CEILING. */
350
351 static tree
build_fixbound_expr(stmtblock_t * pblock,tree arg,tree type,int up)352 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
353 {
354 tree tmp;
355 tree cond;
356 tree argtype;
357 tree intval;
358
359 argtype = TREE_TYPE (arg);
360 arg = gfc_evaluate_now (arg, pblock);
361
362 intval = convert (type, arg);
363 intval = gfc_evaluate_now (intval, pblock);
364
365 tmp = convert (argtype, intval);
366 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
367 logical_type_node, tmp, arg);
368
369 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
370 intval, build_int_cst (type, 1));
371 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
372 return tmp;
373 }
374
375
376 /* Round to nearest integer, away from zero. */
377
378 static tree
build_round_expr(tree arg,tree restype)379 build_round_expr (tree arg, tree restype)
380 {
381 tree argtype;
382 tree fn;
383 int argprec, resprec;
384
385 argtype = TREE_TYPE (arg);
386 argprec = TYPE_PRECISION (argtype);
387 resprec = TYPE_PRECISION (restype);
388
389 /* Depending on the type of the result, choose the int intrinsic
390 (iround, available only as a builtin, therefore cannot use it for
391 __float128), long int intrinsic (lround family) or long long
392 intrinsic (llround). We might also need to convert the result
393 afterwards. */
394 if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
395 fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
396 else if (resprec <= LONG_TYPE_SIZE)
397 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
398 else if (resprec <= LONG_LONG_TYPE_SIZE)
399 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
400 else if (resprec >= argprec && resprec == 128)
401 {
402 /* Search for a real kind suitable as temporary for conversion. */
403 int kind = -1;
404 for (int i = 0; kind < 0 && gfc_real_kinds[i].kind != 0; i++)
405 if (gfc_real_kinds[i].mode_precision >= resprec)
406 kind = gfc_real_kinds[i].kind;
407 if (kind < 0)
408 gfc_internal_error ("Could not find real kind with at least %d bits",
409 resprec);
410 arg = fold_convert (gfc_get_real_type (kind), arg);
411 fn = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
412 }
413 else
414 gcc_unreachable ();
415
416 return convert (restype, build_call_expr_loc (input_location,
417 fn, 1, arg));
418 }
419
420
421 /* Convert a real to an integer using a specific rounding mode.
422 Ideally we would just build the corresponding GENERIC node,
423 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
424
425 static tree
build_fix_expr(stmtblock_t * pblock,tree arg,tree type,enum rounding_mode op)426 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
427 enum rounding_mode op)
428 {
429 switch (op)
430 {
431 case RND_FLOOR:
432 return build_fixbound_expr (pblock, arg, type, 0);
433
434 case RND_CEIL:
435 return build_fixbound_expr (pblock, arg, type, 1);
436
437 case RND_ROUND:
438 return build_round_expr (arg, type);
439
440 case RND_TRUNC:
441 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
442
443 default:
444 gcc_unreachable ();
445 }
446 }
447
448
449 /* Round a real value using the specified rounding mode.
450 We use a temporary integer of that same kind size as the result.
451 Values larger than those that can be represented by this kind are
452 unchanged, as they will not be accurate enough to represent the
453 rounding.
454 huge = HUGE (KIND (a))
455 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
456 */
457
458 static void
gfc_conv_intrinsic_aint(gfc_se * se,gfc_expr * expr,enum rounding_mode op)459 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
460 {
461 tree type;
462 tree itype;
463 tree arg[2];
464 tree tmp;
465 tree cond;
466 tree decl;
467 mpfr_t huge;
468 int n, nargs;
469 int kind;
470
471 kind = expr->ts.kind;
472 nargs = gfc_intrinsic_argument_list_length (expr);
473
474 decl = NULL_TREE;
475 /* We have builtin functions for some cases. */
476 switch (op)
477 {
478 case RND_ROUND:
479 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
480 break;
481
482 case RND_TRUNC:
483 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
484 break;
485
486 default:
487 gcc_unreachable ();
488 }
489
490 /* Evaluate the argument. */
491 gcc_assert (expr->value.function.actual->expr);
492 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
493
494 /* Use a builtin function if one exists. */
495 if (decl != NULL_TREE)
496 {
497 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
498 return;
499 }
500
501 /* This code is probably redundant, but we'll keep it lying around just
502 in case. */
503 type = gfc_typenode_for_spec (&expr->ts);
504 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
505
506 /* Test if the value is too large to handle sensibly. */
507 gfc_set_model_kind (kind);
508 mpfr_init (huge);
509 n = gfc_validate_kind (BT_INTEGER, kind, false);
510 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
511 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
512 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
513 tmp);
514
515 mpfr_neg (huge, huge, GFC_RND_MODE);
516 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
517 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
518 tmp);
519 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
520 cond, tmp);
521 itype = gfc_get_int_type (kind);
522
523 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
524 tmp = convert (type, tmp);
525 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
526 arg[0]);
527 mpfr_clear (huge);
528 }
529
530
531 /* Convert to an integer using the specified rounding mode. */
532
533 static void
gfc_conv_intrinsic_int(gfc_se * se,gfc_expr * expr,enum rounding_mode op)534 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
535 {
536 tree type;
537 tree *args;
538 int nargs;
539
540 nargs = gfc_intrinsic_argument_list_length (expr);
541 args = XALLOCAVEC (tree, nargs);
542
543 /* Evaluate the argument, we process all arguments even though we only
544 use the first one for code generation purposes. */
545 type = gfc_typenode_for_spec (&expr->ts);
546 gcc_assert (expr->value.function.actual->expr);
547 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
548
549 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
550 {
551 /* Conversion to a different integer kind. */
552 se->expr = convert (type, args[0]);
553 }
554 else
555 {
556 /* Conversion from complex to non-complex involves taking the real
557 component of the value. */
558 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
559 && expr->ts.type != BT_COMPLEX)
560 {
561 tree artype;
562
563 artype = TREE_TYPE (TREE_TYPE (args[0]));
564 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
565 args[0]);
566 }
567
568 se->expr = build_fix_expr (&se->pre, args[0], type, op);
569 }
570 }
571
572
573 /* Get the imaginary component of a value. */
574
575 static void
gfc_conv_intrinsic_imagpart(gfc_se * se,gfc_expr * expr)576 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
577 {
578 tree arg;
579
580 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
581 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
582 TREE_TYPE (TREE_TYPE (arg)), arg);
583 }
584
585
586 /* Get the complex conjugate of a value. */
587
588 static void
gfc_conv_intrinsic_conjg(gfc_se * se,gfc_expr * expr)589 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
590 {
591 tree arg;
592
593 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
594 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
595 }
596
597
598
599 static tree
define_quad_builtin(const char * name,tree type,bool is_const)600 define_quad_builtin (const char *name, tree type, bool is_const)
601 {
602 tree fndecl;
603 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
604 type);
605
606 /* Mark the decl as external. */
607 DECL_EXTERNAL (fndecl) = 1;
608 TREE_PUBLIC (fndecl) = 1;
609
610 /* Mark it __attribute__((const)). */
611 TREE_READONLY (fndecl) = is_const;
612
613 rest_of_decl_compilation (fndecl, 1, 0);
614
615 return fndecl;
616 }
617
618 /* Add SIMD attribute for FNDECL built-in if the built-in
619 name is in VECTORIZED_BUILTINS. */
620
621 static void
add_simd_flag_for_built_in(tree fndecl)622 add_simd_flag_for_built_in (tree fndecl)
623 {
624 if (gfc_vectorized_builtins == NULL
625 || fndecl == NULL_TREE)
626 return;
627
628 const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
629 int *clauses = gfc_vectorized_builtins->get (name);
630 if (clauses)
631 {
632 for (unsigned i = 0; i < 3; i++)
633 if (*clauses & (1 << i))
634 {
635 gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
636 tree omp_clause = NULL_TREE;
637 if (simd_type == SIMD_NONE)
638 ; /* No SIMD clause. */
639 else
640 {
641 omp_clause_code code
642 = (simd_type == SIMD_INBRANCH
643 ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
644 omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
645 omp_clause = build_tree_list (NULL_TREE, omp_clause);
646 }
647
648 DECL_ATTRIBUTES (fndecl)
649 = tree_cons (get_identifier ("omp declare simd"), omp_clause,
650 DECL_ATTRIBUTES (fndecl));
651 }
652 }
653 }
654
655 /* Set SIMD attribute to all built-in functions that are mentioned
656 in gfc_vectorized_builtins vector. */
657
658 void
gfc_adjust_builtins(void)659 gfc_adjust_builtins (void)
660 {
661 gfc_intrinsic_map_t *m;
662 for (m = gfc_intrinsic_map;
663 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
664 {
665 add_simd_flag_for_built_in (m->real4_decl);
666 add_simd_flag_for_built_in (m->complex4_decl);
667 add_simd_flag_for_built_in (m->real8_decl);
668 add_simd_flag_for_built_in (m->complex8_decl);
669 add_simd_flag_for_built_in (m->real10_decl);
670 add_simd_flag_for_built_in (m->complex10_decl);
671 add_simd_flag_for_built_in (m->real16_decl);
672 add_simd_flag_for_built_in (m->complex16_decl);
673 add_simd_flag_for_built_in (m->real16_decl);
674 add_simd_flag_for_built_in (m->complex16_decl);
675 }
676
677 /* Release all strings. */
678 if (gfc_vectorized_builtins != NULL)
679 {
680 for (hash_map<nofree_string_hash, int>::iterator it
681 = gfc_vectorized_builtins->begin ();
682 it != gfc_vectorized_builtins->end (); ++it)
683 free (CONST_CAST (char *, (*it).first));
684
685 delete gfc_vectorized_builtins;
686 gfc_vectorized_builtins = NULL;
687 }
688 }
689
690 /* Initialize function decls for library functions. The external functions
691 are created as required. Builtin functions are added here. */
692
693 void
gfc_build_intrinsic_lib_fndecls(void)694 gfc_build_intrinsic_lib_fndecls (void)
695 {
696 gfc_intrinsic_map_t *m;
697 tree quad_decls[END_BUILTINS + 1];
698
699 if (gfc_real16_is_float128)
700 {
701 /* If we have soft-float types, we create the decls for their
702 C99-like library functions. For now, we only handle __float128
703 q-suffixed functions. */
704
705 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
706 tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
707
708 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
709
710 type = gfc_float128_type_node;
711 complex_type = gfc_complex_float128_type_node;
712 /* type (*) (type) */
713 func_1 = build_function_type_list (type, type, NULL_TREE);
714 /* int (*) (type) */
715 func_iround = build_function_type_list (integer_type_node,
716 type, NULL_TREE);
717 /* long (*) (type) */
718 func_lround = build_function_type_list (long_integer_type_node,
719 type, NULL_TREE);
720 /* long long (*) (type) */
721 func_llround = build_function_type_list (long_long_integer_type_node,
722 type, NULL_TREE);
723 /* type (*) (type, type) */
724 func_2 = build_function_type_list (type, type, type, NULL_TREE);
725 /* type (*) (type, &int) */
726 func_frexp
727 = build_function_type_list (type,
728 type,
729 build_pointer_type (integer_type_node),
730 NULL_TREE);
731 /* type (*) (type, int) */
732 func_scalbn = build_function_type_list (type,
733 type, integer_type_node, NULL_TREE);
734 /* type (*) (complex type) */
735 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
736 /* complex type (*) (complex type, complex type) */
737 func_cpow
738 = build_function_type_list (complex_type,
739 complex_type, complex_type, NULL_TREE);
740
741 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
742 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
743 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
744
745 /* Only these built-ins are actually needed here. These are used directly
746 from the code, when calling builtin_decl_for_precision() or
747 builtin_decl_for_float_type(). The others are all constructed by
748 gfc_get_intrinsic_lib_fndecl(). */
749 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
750 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
751
752 #include "mathbuiltins.def"
753
754 #undef OTHER_BUILTIN
755 #undef LIB_FUNCTION
756 #undef DEFINE_MATH_BUILTIN
757 #undef DEFINE_MATH_BUILTIN_C
758
759 /* There is one built-in we defined manually, because it gets called
760 with builtin_decl_for_precision() or builtin_decl_for_float_type()
761 even though it is not an OTHER_BUILTIN: it is SQRT. */
762 quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true);
763
764 }
765
766 /* Add GCC builtin functions. */
767 for (m = gfc_intrinsic_map;
768 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
769 {
770 if (m->float_built_in != END_BUILTINS)
771 m->real4_decl = builtin_decl_explicit (m->float_built_in);
772 if (m->complex_float_built_in != END_BUILTINS)
773 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
774 if (m->double_built_in != END_BUILTINS)
775 m->real8_decl = builtin_decl_explicit (m->double_built_in);
776 if (m->complex_double_built_in != END_BUILTINS)
777 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
778
779 /* If real(kind=10) exists, it is always long double. */
780 if (m->long_double_built_in != END_BUILTINS)
781 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
782 if (m->complex_long_double_built_in != END_BUILTINS)
783 m->complex10_decl
784 = builtin_decl_explicit (m->complex_long_double_built_in);
785
786 if (!gfc_real16_is_float128)
787 {
788 if (m->long_double_built_in != END_BUILTINS)
789 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
790 if (m->complex_long_double_built_in != END_BUILTINS)
791 m->complex16_decl
792 = builtin_decl_explicit (m->complex_long_double_built_in);
793 }
794 else if (quad_decls[m->double_built_in] != NULL_TREE)
795 {
796 /* Quad-precision function calls are constructed when first
797 needed by builtin_decl_for_precision(), except for those
798 that will be used directly (define by OTHER_BUILTIN). */
799 m->real16_decl = quad_decls[m->double_built_in];
800 }
801 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
802 {
803 /* Same thing for the complex ones. */
804 m->complex16_decl = quad_decls[m->double_built_in];
805 }
806 }
807 }
808
809
810 /* Create a fndecl for a simple intrinsic library function. */
811
812 static tree
gfc_get_intrinsic_lib_fndecl(gfc_intrinsic_map_t * m,gfc_expr * expr)813 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
814 {
815 tree type;
816 vec<tree, va_gc> *argtypes;
817 tree fndecl;
818 gfc_actual_arglist *actual;
819 tree *pdecl;
820 gfc_typespec *ts;
821 char name[GFC_MAX_SYMBOL_LEN + 3];
822
823 ts = &expr->ts;
824 if (ts->type == BT_REAL)
825 {
826 switch (ts->kind)
827 {
828 case 4:
829 pdecl = &m->real4_decl;
830 break;
831 case 8:
832 pdecl = &m->real8_decl;
833 break;
834 case 10:
835 pdecl = &m->real10_decl;
836 break;
837 case 16:
838 pdecl = &m->real16_decl;
839 break;
840 default:
841 gcc_unreachable ();
842 }
843 }
844 else if (ts->type == BT_COMPLEX)
845 {
846 gcc_assert (m->complex_available);
847
848 switch (ts->kind)
849 {
850 case 4:
851 pdecl = &m->complex4_decl;
852 break;
853 case 8:
854 pdecl = &m->complex8_decl;
855 break;
856 case 10:
857 pdecl = &m->complex10_decl;
858 break;
859 case 16:
860 pdecl = &m->complex16_decl;
861 break;
862 default:
863 gcc_unreachable ();
864 }
865 }
866 else
867 gcc_unreachable ();
868
869 if (*pdecl)
870 return *pdecl;
871
872 if (m->libm_name)
873 {
874 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
875 if (gfc_real_kinds[n].c_float)
876 snprintf (name, sizeof (name), "%s%s%s",
877 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
878 else if (gfc_real_kinds[n].c_double)
879 snprintf (name, sizeof (name), "%s%s",
880 ts->type == BT_COMPLEX ? "c" : "", m->name);
881 else if (gfc_real_kinds[n].c_long_double)
882 snprintf (name, sizeof (name), "%s%s%s",
883 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
884 else if (gfc_real_kinds[n].c_float128)
885 snprintf (name, sizeof (name), "%s%s%s",
886 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
887 else
888 gcc_unreachable ();
889 }
890 else
891 {
892 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
893 ts->type == BT_COMPLEX ? 'c' : 'r',
894 ts->kind);
895 }
896
897 argtypes = NULL;
898 for (actual = expr->value.function.actual; actual; actual = actual->next)
899 {
900 type = gfc_typenode_for_spec (&actual->expr->ts);
901 vec_safe_push (argtypes, type);
902 }
903 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
904 fndecl = build_decl (input_location,
905 FUNCTION_DECL, get_identifier (name), type);
906
907 /* Mark the decl as external. */
908 DECL_EXTERNAL (fndecl) = 1;
909 TREE_PUBLIC (fndecl) = 1;
910
911 /* Mark it __attribute__((const)), if possible. */
912 TREE_READONLY (fndecl) = m->is_constant;
913
914 rest_of_decl_compilation (fndecl, 1, 0);
915
916 (*pdecl) = fndecl;
917 return fndecl;
918 }
919
920
921 /* Convert an intrinsic function into an external or builtin call. */
922
923 static void
gfc_conv_intrinsic_lib_function(gfc_se * se,gfc_expr * expr)924 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
925 {
926 gfc_intrinsic_map_t *m;
927 tree fndecl;
928 tree rettype;
929 tree *args;
930 unsigned int num_args;
931 gfc_isym_id id;
932
933 id = expr->value.function.isym->id;
934 /* Find the entry for this function. */
935 for (m = gfc_intrinsic_map;
936 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
937 {
938 if (id == m->id)
939 break;
940 }
941
942 if (m->id == GFC_ISYM_NONE)
943 {
944 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
945 expr->value.function.name, id);
946 }
947
948 /* Get the decl and generate the call. */
949 num_args = gfc_intrinsic_argument_list_length (expr);
950 args = XALLOCAVEC (tree, num_args);
951
952 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
953 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
954 rettype = TREE_TYPE (TREE_TYPE (fndecl));
955
956 fndecl = build_addr (fndecl);
957 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
958 }
959
960
961 /* If bounds-checking is enabled, create code to verify at runtime that the
962 string lengths for both expressions are the same (needed for e.g. MERGE).
963 If bounds-checking is not enabled, does nothing. */
964
965 void
gfc_trans_same_strlen_check(const char * intr_name,locus * where,tree a,tree b,stmtblock_t * target)966 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
967 tree a, tree b, stmtblock_t* target)
968 {
969 tree cond;
970 tree name;
971
972 /* If bounds-checking is disabled, do nothing. */
973 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
974 return;
975
976 /* Compare the two string lengths. */
977 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
978
979 /* Output the runtime-check. */
980 name = gfc_build_cstring_const (intr_name);
981 name = gfc_build_addr_expr (pchar_type_node, name);
982 gfc_trans_runtime_check (true, false, cond, target, where,
983 "Unequal character lengths (%ld/%ld) in %s",
984 fold_convert (long_integer_type_node, a),
985 fold_convert (long_integer_type_node, b), name);
986 }
987
988
989 /* The EXPONENT(X) intrinsic function is translated into
990 int ret;
991 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
992 so that if X is a NaN or infinity, the result is HUGE(0).
993 */
994
995 static void
gfc_conv_intrinsic_exponent(gfc_se * se,gfc_expr * expr)996 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
997 {
998 tree arg, type, res, tmp, frexp, cond, huge;
999 int i;
1000
1001 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1002 expr->value.function.actual->expr->ts.kind);
1003
1004 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1005 arg = gfc_evaluate_now (arg, &se->pre);
1006
1007 i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1008 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1009 cond = build_call_expr_loc (input_location,
1010 builtin_decl_explicit (BUILT_IN_ISFINITE),
1011 1, arg);
1012
1013 res = gfc_create_var (integer_type_node, NULL);
1014 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1015 gfc_build_addr_expr (NULL_TREE, res));
1016 tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1017 tmp, res);
1018 se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1019 cond, tmp, huge);
1020
1021 type = gfc_typenode_for_spec (&expr->ts);
1022 se->expr = fold_convert (type, se->expr);
1023 }
1024
1025
1026 /* Fill in the following structure
1027 struct caf_vector_t {
1028 size_t nvec; // size of the vector
1029 union {
1030 struct {
1031 void *vector;
1032 int kind;
1033 } v;
1034 struct {
1035 ptrdiff_t lower_bound;
1036 ptrdiff_t upper_bound;
1037 ptrdiff_t stride;
1038 } triplet;
1039 } u;
1040 } */
1041
1042 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)1043 conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
1044 tree lower, tree upper, tree stride,
1045 tree vector, int kind, tree nvec)
1046 {
1047 tree field, type, tmp;
1048
1049 desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
1050 type = TREE_TYPE (desc);
1051
1052 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1053 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1054 desc, field, NULL_TREE);
1055 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
1056
1057 /* Access union. */
1058 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1059 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1060 desc, field, NULL_TREE);
1061 type = TREE_TYPE (desc);
1062
1063 /* Access the inner struct. */
1064 field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
1065 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1066 desc, field, NULL_TREE);
1067 type = TREE_TYPE (desc);
1068
1069 if (vector != NULL_TREE)
1070 {
1071 /* Set vector and kind. */
1072 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1073 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1074 desc, field, NULL_TREE);
1075 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
1076 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1077 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1078 desc, field, NULL_TREE);
1079 gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
1080 }
1081 else
1082 {
1083 /* Set dim.lower/upper/stride. */
1084 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1085 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1086 desc, field, NULL_TREE);
1087 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
1088
1089 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1090 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1091 desc, field, NULL_TREE);
1092 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1093
1094 field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1095 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1096 desc, field, NULL_TREE);
1097 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1098 }
1099 }
1100
1101
1102 static tree
conv_caf_vector_subscript(stmtblock_t * block,tree desc,gfc_array_ref * ar)1103 conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1104 {
1105 gfc_se argse;
1106 tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1107 tree lbound, ubound, tmp;
1108 int i;
1109
1110 var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1111
1112 for (i = 0; i < ar->dimen; i++)
1113 switch (ar->dimen_type[i])
1114 {
1115 case DIMEN_RANGE:
1116 if (ar->end[i])
1117 {
1118 gfc_init_se (&argse, NULL);
1119 gfc_conv_expr (&argse, ar->end[i]);
1120 gfc_add_block_to_block (block, &argse.pre);
1121 upper = gfc_evaluate_now (argse.expr, block);
1122 }
1123 else
1124 upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1125 if (ar->stride[i])
1126 {
1127 gfc_init_se (&argse, NULL);
1128 gfc_conv_expr (&argse, ar->stride[i]);
1129 gfc_add_block_to_block (block, &argse.pre);
1130 stride = gfc_evaluate_now (argse.expr, block);
1131 }
1132 else
1133 stride = gfc_index_one_node;
1134
1135 /* Fall through. */
1136 case DIMEN_ELEMENT:
1137 if (ar->start[i])
1138 {
1139 gfc_init_se (&argse, NULL);
1140 gfc_conv_expr (&argse, ar->start[i]);
1141 gfc_add_block_to_block (block, &argse.pre);
1142 lower = gfc_evaluate_now (argse.expr, block);
1143 }
1144 else
1145 lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1146 if (ar->dimen_type[i] == DIMEN_ELEMENT)
1147 {
1148 upper = lower;
1149 stride = gfc_index_one_node;
1150 }
1151 vector = NULL_TREE;
1152 nvec = size_zero_node;
1153 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1154 vector, 0, nvec);
1155 break;
1156
1157 case DIMEN_VECTOR:
1158 gfc_init_se (&argse, NULL);
1159 argse.descriptor_only = 1;
1160 gfc_conv_expr_descriptor (&argse, ar->start[i]);
1161 gfc_add_block_to_block (block, &argse.pre);
1162 vector = argse.expr;
1163 lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1164 ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1165 nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1166 tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1167 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1168 TREE_TYPE (nvec), nvec, tmp);
1169 lower = gfc_index_zero_node;
1170 upper = gfc_index_zero_node;
1171 stride = gfc_index_zero_node;
1172 vector = gfc_conv_descriptor_data_get (vector);
1173 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1174 vector, ar->start[i]->ts.kind, nvec);
1175 break;
1176 default:
1177 gcc_unreachable();
1178 }
1179 return gfc_build_addr_expr (NULL_TREE, var);
1180 }
1181
1182
1183 static tree
compute_component_offset(tree field,tree type)1184 compute_component_offset (tree field, tree type)
1185 {
1186 tree tmp;
1187 if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
1188 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
1189 {
1190 tmp = fold_build2 (TRUNC_DIV_EXPR, type,
1191 DECL_FIELD_BIT_OFFSET (field),
1192 bitsize_unit_node);
1193 return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
1194 }
1195 else
1196 return DECL_FIELD_OFFSET (field);
1197 }
1198
1199
1200 static tree
conv_expr_ref_to_caf_ref(stmtblock_t * block,gfc_expr * expr)1201 conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1202 {
1203 gfc_ref *ref = expr->ref, *last_comp_ref;
1204 tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
1205 field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1206 start, end, stride, vector, nvec;
1207 gfc_se se;
1208 bool ref_static_array = false;
1209 tree last_component_ref_tree = NULL_TREE;
1210 int i, last_type_n;
1211
1212 if (expr->symtree)
1213 {
1214 last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1215 ref_static_array = !expr->symtree->n.sym->attr.allocatable
1216 && !expr->symtree->n.sym->attr.pointer;
1217 }
1218
1219 /* Prevent uninit-warning. */
1220 reference_type = NULL_TREE;
1221
1222 /* Skip refs upto the first coarray-ref. */
1223 last_comp_ref = NULL;
1224 while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1225 {
1226 /* Remember the type of components skipped. */
1227 if (ref->type == REF_COMPONENT)
1228 last_comp_ref = ref;
1229 ref = ref->next;
1230 }
1231 /* When a component was skipped, get the type information of the last
1232 component ref, else get the type from the symbol. */
1233 if (last_comp_ref)
1234 {
1235 last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1236 last_type_n = last_comp_ref->u.c.component->ts.type;
1237 }
1238 else
1239 {
1240 last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1241 last_type_n = expr->symtree->n.sym->ts.type;
1242 }
1243
1244 while (ref)
1245 {
1246 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1247 && ref->u.ar.dimen == 0)
1248 {
1249 /* Skip pure coindexes. */
1250 ref = ref->next;
1251 continue;
1252 }
1253 tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1254 reference_type = TREE_TYPE (tmp);
1255
1256 if (caf_ref == NULL_TREE)
1257 caf_ref = tmp;
1258
1259 /* Construct the chain of refs. */
1260 if (prev_caf_ref != NULL_TREE)
1261 {
1262 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1263 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1264 TREE_TYPE (field), prev_caf_ref, field,
1265 NULL_TREE);
1266 gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
1267 tmp));
1268 }
1269 prev_caf_ref = tmp;
1270
1271 switch (ref->type)
1272 {
1273 case REF_COMPONENT:
1274 last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1275 last_type_n = ref->u.c.component->ts.type;
1276 /* Set the type of the ref. */
1277 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1278 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1279 TREE_TYPE (field), prev_caf_ref, field,
1280 NULL_TREE);
1281 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1282 GFC_CAF_REF_COMPONENT));
1283
1284 /* Ref the c in union u. */
1285 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1286 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1287 TREE_TYPE (field), prev_caf_ref, field,
1288 NULL_TREE);
1289 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
1290 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1291 TREE_TYPE (field), tmp, field,
1292 NULL_TREE);
1293
1294 /* Set the offset. */
1295 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1296 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1297 TREE_TYPE (field), inner_struct, field,
1298 NULL_TREE);
1299 /* Computing the offset is somewhat harder. The bit_offset has to be
1300 taken into account. When the bit_offset in the field_decl is non-
1301 null, divide it by the bitsize_unit and add it to the regular
1302 offset. */
1303 tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
1304 TREE_TYPE (tmp));
1305 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1306
1307 /* Set caf_token_offset. */
1308 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
1309 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1310 TREE_TYPE (field), inner_struct, field,
1311 NULL_TREE);
1312 if ((ref->u.c.component->attr.allocatable
1313 || ref->u.c.component->attr.pointer)
1314 && ref->u.c.component->attr.dimension)
1315 {
1316 tree arr_desc_token_offset;
1317 /* Get the token field from the descriptor. */
1318 arr_desc_token_offset = TREE_OPERAND (
1319 gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
1320 arr_desc_token_offset
1321 = compute_component_offset (arr_desc_token_offset,
1322 TREE_TYPE (tmp));
1323 tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1324 TREE_TYPE (tmp2), tmp2,
1325 arr_desc_token_offset);
1326 }
1327 else if (ref->u.c.component->caf_token)
1328 tmp2 = compute_component_offset (ref->u.c.component->caf_token,
1329 TREE_TYPE (tmp));
1330 else
1331 tmp2 = integer_zero_node;
1332 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1333
1334 /* Remember whether this ref was to a non-allocatable/non-pointer
1335 component so the next array ref can be tailored correctly. */
1336 ref_static_array = !ref->u.c.component->attr.allocatable
1337 && !ref->u.c.component->attr.pointer;
1338 last_component_ref_tree = ref_static_array
1339 ? ref->u.c.component->backend_decl : NULL_TREE;
1340 break;
1341 case REF_ARRAY:
1342 if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1343 ref_static_array = false;
1344 /* Set the type of the ref. */
1345 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1346 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1347 TREE_TYPE (field), prev_caf_ref, field,
1348 NULL_TREE);
1349 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1350 ref_static_array
1351 ? GFC_CAF_REF_STATIC_ARRAY
1352 : GFC_CAF_REF_ARRAY));
1353
1354 /* Ref the a in union u. */
1355 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1356 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1357 TREE_TYPE (field), prev_caf_ref, field,
1358 NULL_TREE);
1359 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
1360 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1361 TREE_TYPE (field), tmp, field,
1362 NULL_TREE);
1363
1364 /* Set the static_array_type in a for static arrays. */
1365 if (ref_static_array)
1366 {
1367 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
1368 1);
1369 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1370 TREE_TYPE (field), inner_struct, field,
1371 NULL_TREE);
1372 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
1373 last_type_n));
1374 }
1375 /* Ref the mode in the inner_struct. */
1376 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1377 mode = fold_build3_loc (input_location, COMPONENT_REF,
1378 TREE_TYPE (field), inner_struct, field,
1379 NULL_TREE);
1380 /* Ref the dim in the inner_struct. */
1381 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
1382 dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1383 TREE_TYPE (field), inner_struct, field,
1384 NULL_TREE);
1385 for (i = 0; i < ref->u.ar.dimen; ++i)
1386 {
1387 /* Ref dim i. */
1388 dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
1389 dim_type = TREE_TYPE (dim);
1390 mode_rhs = start = end = stride = NULL_TREE;
1391 switch (ref->u.ar.dimen_type[i])
1392 {
1393 case DIMEN_RANGE:
1394 if (ref->u.ar.end[i])
1395 {
1396 gfc_init_se (&se, NULL);
1397 gfc_conv_expr (&se, ref->u.ar.end[i]);
1398 gfc_add_block_to_block (block, &se.pre);
1399 if (ref_static_array)
1400 {
1401 /* Make the index zero-based, when reffing a static
1402 array. */
1403 end = se.expr;
1404 gfc_init_se (&se, NULL);
1405 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1406 gfc_add_block_to_block (block, &se.pre);
1407 se.expr = fold_build2 (MINUS_EXPR,
1408 gfc_array_index_type,
1409 end, fold_convert (
1410 gfc_array_index_type,
1411 se.expr));
1412 }
1413 end = gfc_evaluate_now (fold_convert (
1414 gfc_array_index_type,
1415 se.expr),
1416 block);
1417 }
1418 else if (ref_static_array)
1419 end = fold_build2 (MINUS_EXPR,
1420 gfc_array_index_type,
1421 gfc_conv_array_ubound (
1422 last_component_ref_tree, i),
1423 gfc_conv_array_lbound (
1424 last_component_ref_tree, i));
1425 else
1426 {
1427 end = NULL_TREE;
1428 mode_rhs = build_int_cst (unsigned_char_type_node,
1429 GFC_CAF_ARR_REF_OPEN_END);
1430 }
1431 if (ref->u.ar.stride[i])
1432 {
1433 gfc_init_se (&se, NULL);
1434 gfc_conv_expr (&se, ref->u.ar.stride[i]);
1435 gfc_add_block_to_block (block, &se.pre);
1436 stride = gfc_evaluate_now (fold_convert (
1437 gfc_array_index_type,
1438 se.expr),
1439 block);
1440 if (ref_static_array)
1441 {
1442 /* Make the index zero-based, when reffing a static
1443 array. */
1444 stride = fold_build2 (MULT_EXPR,
1445 gfc_array_index_type,
1446 gfc_conv_array_stride (
1447 last_component_ref_tree,
1448 i),
1449 stride);
1450 gcc_assert (end != NULL_TREE);
1451 /* Multiply with the product of array's stride and
1452 the step of the ref to a virtual upper bound.
1453 We cannot compute the actual upper bound here or
1454 the caflib would compute the extend
1455 incorrectly. */
1456 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1457 end, gfc_conv_array_stride (
1458 last_component_ref_tree,
1459 i));
1460 end = gfc_evaluate_now (end, block);
1461 stride = gfc_evaluate_now (stride, block);
1462 }
1463 }
1464 else if (ref_static_array)
1465 {
1466 stride = gfc_conv_array_stride (last_component_ref_tree,
1467 i);
1468 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1469 end, stride);
1470 end = gfc_evaluate_now (end, block);
1471 }
1472 else
1473 /* Always set a ref stride of one to make caflib's
1474 handling easier. */
1475 stride = gfc_index_one_node;
1476
1477 /* Fall through. */
1478 case DIMEN_ELEMENT:
1479 if (ref->u.ar.start[i])
1480 {
1481 gfc_init_se (&se, NULL);
1482 gfc_conv_expr (&se, ref->u.ar.start[i]);
1483 gfc_add_block_to_block (block, &se.pre);
1484 if (ref_static_array)
1485 {
1486 /* Make the index zero-based, when reffing a static
1487 array. */
1488 start = fold_convert (gfc_array_index_type, se.expr);
1489 gfc_init_se (&se, NULL);
1490 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1491 gfc_add_block_to_block (block, &se.pre);
1492 se.expr = fold_build2 (MINUS_EXPR,
1493 gfc_array_index_type,
1494 start, fold_convert (
1495 gfc_array_index_type,
1496 se.expr));
1497 /* Multiply with the stride. */
1498 se.expr = fold_build2 (MULT_EXPR,
1499 gfc_array_index_type,
1500 se.expr,
1501 gfc_conv_array_stride (
1502 last_component_ref_tree,
1503 i));
1504 }
1505 start = gfc_evaluate_now (fold_convert (
1506 gfc_array_index_type,
1507 se.expr),
1508 block);
1509 if (mode_rhs == NULL_TREE)
1510 mode_rhs = build_int_cst (unsigned_char_type_node,
1511 ref->u.ar.dimen_type[i]
1512 == DIMEN_ELEMENT
1513 ? GFC_CAF_ARR_REF_SINGLE
1514 : GFC_CAF_ARR_REF_RANGE);
1515 }
1516 else if (ref_static_array)
1517 {
1518 start = integer_zero_node;
1519 mode_rhs = build_int_cst (unsigned_char_type_node,
1520 ref->u.ar.start[i] == NULL
1521 ? GFC_CAF_ARR_REF_FULL
1522 : GFC_CAF_ARR_REF_RANGE);
1523 }
1524 else if (end == NULL_TREE)
1525 mode_rhs = build_int_cst (unsigned_char_type_node,
1526 GFC_CAF_ARR_REF_FULL);
1527 else
1528 mode_rhs = build_int_cst (unsigned_char_type_node,
1529 GFC_CAF_ARR_REF_OPEN_START);
1530
1531 /* Ref the s in dim. */
1532 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
1533 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1534 TREE_TYPE (field), dim, field,
1535 NULL_TREE);
1536
1537 /* Set start in s. */
1538 if (start != NULL_TREE)
1539 {
1540 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1541 0);
1542 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1543 TREE_TYPE (field), tmp, field,
1544 NULL_TREE);
1545 gfc_add_modify (block, tmp2,
1546 fold_convert (TREE_TYPE (tmp2), start));
1547 }
1548
1549 /* Set end in s. */
1550 if (end != NULL_TREE)
1551 {
1552 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1553 1);
1554 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1555 TREE_TYPE (field), tmp, field,
1556 NULL_TREE);
1557 gfc_add_modify (block, tmp2,
1558 fold_convert (TREE_TYPE (tmp2), end));
1559 }
1560
1561 /* Set end in s. */
1562 if (stride != NULL_TREE)
1563 {
1564 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1565 2);
1566 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1567 TREE_TYPE (field), tmp, field,
1568 NULL_TREE);
1569 gfc_add_modify (block, tmp2,
1570 fold_convert (TREE_TYPE (tmp2), stride));
1571 }
1572 break;
1573 case DIMEN_VECTOR:
1574 /* TODO: In case of static array. */
1575 gcc_assert (!ref_static_array);
1576 mode_rhs = build_int_cst (unsigned_char_type_node,
1577 GFC_CAF_ARR_REF_VECTOR);
1578 gfc_init_se (&se, NULL);
1579 se.descriptor_only = 1;
1580 gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1581 gfc_add_block_to_block (block, &se.pre);
1582 vector = se.expr;
1583 tmp = gfc_conv_descriptor_lbound_get (vector,
1584 gfc_rank_cst[0]);
1585 tmp2 = gfc_conv_descriptor_ubound_get (vector,
1586 gfc_rank_cst[0]);
1587 nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
1588 tmp = gfc_conv_descriptor_stride_get (vector,
1589 gfc_rank_cst[0]);
1590 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1591 TREE_TYPE (nvec), nvec, tmp);
1592 vector = gfc_conv_descriptor_data_get (vector);
1593
1594 /* Ref the v in dim. */
1595 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
1596 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1597 TREE_TYPE (field), dim, field,
1598 NULL_TREE);
1599
1600 /* Set vector in v. */
1601 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
1602 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1603 TREE_TYPE (field), tmp, field,
1604 NULL_TREE);
1605 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1606 vector));
1607
1608 /* Set nvec in v. */
1609 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
1610 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1611 TREE_TYPE (field), tmp, field,
1612 NULL_TREE);
1613 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1614 nvec));
1615
1616 /* Set kind in v. */
1617 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
1618 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1619 TREE_TYPE (field), tmp, field,
1620 NULL_TREE);
1621 gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
1622 ref->u.ar.start[i]->ts.kind));
1623 break;
1624 default:
1625 gcc_unreachable ();
1626 }
1627 /* Set the mode for dim i. */
1628 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1629 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
1630 mode_rhs));
1631 }
1632
1633 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1634 if (i < GFC_MAX_DIMENSIONS)
1635 {
1636 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1637 gfc_add_modify (block, tmp,
1638 build_int_cst (unsigned_char_type_node,
1639 GFC_CAF_ARR_REF_NONE));
1640 }
1641 break;
1642 default:
1643 gcc_unreachable ();
1644 }
1645
1646 /* Set the size of the current type. */
1647 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
1648 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1649 prev_caf_ref, field, NULL_TREE);
1650 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1651 TYPE_SIZE_UNIT (last_type)));
1652
1653 ref = ref->next;
1654 }
1655
1656 if (prev_caf_ref != NULL_TREE)
1657 {
1658 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1659 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1660 prev_caf_ref, field, NULL_TREE);
1661 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1662 null_pointer_node));
1663 }
1664 return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
1665 : NULL_TREE;
1666 }
1667
1668 /* Get data from a remote coarray. */
1669
1670 static void
gfc_conv_intrinsic_caf_get(gfc_se * se,gfc_expr * expr,tree lhs,tree lhs_kind,tree may_require_tmp,bool may_realloc,symbol_attribute * caf_attr)1671 gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1672 tree may_require_tmp, bool may_realloc,
1673 symbol_attribute *caf_attr)
1674 {
1675 gfc_expr *array_expr, *tmp_stat;
1676 gfc_se argse;
1677 tree caf_decl, token, offset, image_index, tmp;
1678 tree res_var, dst_var, type, kind, vec, stat;
1679 tree caf_reference;
1680 symbol_attribute caf_attr_store;
1681
1682 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1683
1684 if (se->ss && se->ss->info->useflags)
1685 {
1686 /* Access the previously obtained result. */
1687 gfc_conv_tmp_array_ref (se);
1688 return;
1689 }
1690
1691 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1692 array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1693 type = gfc_typenode_for_spec (&array_expr->ts);
1694
1695 if (caf_attr == NULL)
1696 {
1697 caf_attr_store = gfc_caf_attr (array_expr);
1698 caf_attr = &caf_attr_store;
1699 }
1700
1701 res_var = lhs;
1702 dst_var = lhs;
1703
1704 vec = null_pointer_node;
1705 tmp_stat = gfc_find_stat_co (expr);
1706
1707 if (tmp_stat)
1708 {
1709 gfc_se stat_se;
1710 gfc_init_se (&stat_se, NULL);
1711 gfc_conv_expr_reference (&stat_se, tmp_stat);
1712 stat = stat_se.expr;
1713 gfc_add_block_to_block (&se->pre, &stat_se.pre);
1714 gfc_add_block_to_block (&se->post, &stat_se.post);
1715 }
1716 else
1717 stat = null_pointer_node;
1718
1719 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1720 is reallocatable or the right-hand side has allocatable components. */
1721 if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1722 {
1723 /* Get using caf_get_by_ref. */
1724 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
1725
1726 if (caf_reference != NULL_TREE)
1727 {
1728 if (lhs == NULL_TREE)
1729 {
1730 if (array_expr->ts.type == BT_CHARACTER)
1731 gfc_init_se (&argse, NULL);
1732 if (array_expr->rank == 0)
1733 {
1734 symbol_attribute attr;
1735 gfc_clear_attr (&attr);
1736 if (array_expr->ts.type == BT_CHARACTER)
1737 {
1738 res_var = gfc_conv_string_tmp (se,
1739 build_pointer_type (type),
1740 array_expr->ts.u.cl->backend_decl);
1741 argse.string_length = array_expr->ts.u.cl->backend_decl;
1742 }
1743 else
1744 res_var = gfc_create_var (type, "caf_res");
1745 dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1746 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1747 }
1748 else
1749 {
1750 /* Create temporary. */
1751 if (array_expr->ts.type == BT_CHARACTER)
1752 gfc_conv_expr_descriptor (&argse, array_expr);
1753 may_realloc = gfc_trans_create_temp_array (&se->pre,
1754 &se->post,
1755 se->ss, type,
1756 NULL_TREE, false,
1757 false, false,
1758 &array_expr->where)
1759 == NULL_TREE;
1760 res_var = se->ss->info->data.array.descriptor;
1761 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1762 if (may_realloc)
1763 {
1764 tmp = gfc_conv_descriptor_data_get (res_var);
1765 tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
1766 NULL_TREE, NULL_TREE,
1767 NULL_TREE, true,
1768 NULL,
1769 GFC_CAF_COARRAY_NOCOARRAY);
1770 gfc_add_expr_to_block (&se->post, tmp);
1771 }
1772 }
1773 }
1774
1775 kind = build_int_cst (integer_type_node, expr->ts.kind);
1776 if (lhs_kind == NULL_TREE)
1777 lhs_kind = kind;
1778
1779 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1780 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1781 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1782 image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1783 caf_decl);
1784 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
1785 array_expr);
1786
1787 /* No overlap possible as we have generated a temporary. */
1788 if (lhs == NULL_TREE)
1789 may_require_tmp = boolean_false_node;
1790
1791 /* It guarantees memory consistency within the same segment. */
1792 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1793 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1794 gfc_build_string_const (1, ""), NULL_TREE,
1795 NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE),
1796 NULL_TREE);
1797 ASM_VOLATILE_P (tmp) = 1;
1798 gfc_add_expr_to_block (&se->pre, tmp);
1799
1800 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1801 10, token, image_index, dst_var,
1802 caf_reference, lhs_kind, kind,
1803 may_require_tmp,
1804 may_realloc ? boolean_true_node :
1805 boolean_false_node,
1806 stat, build_int_cst (integer_type_node,
1807 array_expr->ts.type));
1808
1809 gfc_add_expr_to_block (&se->pre, tmp);
1810
1811 if (se->ss)
1812 gfc_advance_se_ss_chain (se);
1813
1814 se->expr = res_var;
1815 if (array_expr->ts.type == BT_CHARACTER)
1816 se->string_length = argse.string_length;
1817
1818 return;
1819 }
1820 }
1821
1822 gfc_init_se (&argse, NULL);
1823 if (array_expr->rank == 0)
1824 {
1825 symbol_attribute attr;
1826
1827 gfc_clear_attr (&attr);
1828 gfc_conv_expr (&argse, array_expr);
1829
1830 if (lhs == NULL_TREE)
1831 {
1832 gfc_clear_attr (&attr);
1833 if (array_expr->ts.type == BT_CHARACTER)
1834 res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1835 argse.string_length);
1836 else
1837 res_var = gfc_create_var (type, "caf_res");
1838 dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1839 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1840 }
1841 argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1842 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1843 }
1844 else
1845 {
1846 /* If has_vector, pass descriptor for whole array and the
1847 vector bounds separately. */
1848 gfc_array_ref *ar, ar2;
1849 bool has_vector = false;
1850
1851 if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1852 {
1853 has_vector = true;
1854 ar = gfc_find_array_ref (expr);
1855 ar2 = *ar;
1856 memset (ar, '\0', sizeof (*ar));
1857 ar->as = ar2.as;
1858 ar->type = AR_FULL;
1859 }
1860 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1861 gfc_conv_expr_descriptor (&argse, array_expr);
1862 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1863 has the wrong type if component references are done. */
1864 gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1865 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1866 : array_expr->rank,
1867 type));
1868 if (has_vector)
1869 {
1870 vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1871 *ar = ar2;
1872 }
1873
1874 if (lhs == NULL_TREE)
1875 {
1876 /* Create temporary. */
1877 for (int n = 0; n < se->ss->loop->dimen; n++)
1878 if (se->loop->to[n] == NULL_TREE)
1879 {
1880 se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1881 gfc_rank_cst[n]);
1882 se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1883 gfc_rank_cst[n]);
1884 }
1885 gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1886 NULL_TREE, false, true, false,
1887 &array_expr->where);
1888 res_var = se->ss->info->data.array.descriptor;
1889 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1890 }
1891 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1892 }
1893
1894 kind = build_int_cst (integer_type_node, expr->ts.kind);
1895 if (lhs_kind == NULL_TREE)
1896 lhs_kind = kind;
1897
1898 gfc_add_block_to_block (&se->pre, &argse.pre);
1899 gfc_add_block_to_block (&se->post, &argse.post);
1900
1901 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1902 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1903 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1904 image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1905 gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1906 array_expr);
1907
1908 /* No overlap possible as we have generated a temporary. */
1909 if (lhs == NULL_TREE)
1910 may_require_tmp = boolean_false_node;
1911
1912 /* It guarantees memory consistency within the same segment. */
1913 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1914 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1915 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1916 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1917 ASM_VOLATILE_P (tmp) = 1;
1918 gfc_add_expr_to_block (&se->pre, tmp);
1919
1920 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1921 token, offset, image_index, argse.expr, vec,
1922 dst_var, kind, lhs_kind, may_require_tmp, stat);
1923
1924 gfc_add_expr_to_block (&se->pre, tmp);
1925
1926 if (se->ss)
1927 gfc_advance_se_ss_chain (se);
1928
1929 se->expr = res_var;
1930 if (array_expr->ts.type == BT_CHARACTER)
1931 se->string_length = argse.string_length;
1932 }
1933
1934
1935 /* Send data to a remote coarray. */
1936
1937 static tree
conv_caf_send(gfc_code * code)1938 conv_caf_send (gfc_code *code) {
1939 gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
1940 gfc_se lhs_se, rhs_se;
1941 stmtblock_t block;
1942 tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1943 tree may_require_tmp, src_stat, dst_stat, dst_team;
1944 tree lhs_type = NULL_TREE;
1945 tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1946 symbol_attribute lhs_caf_attr, rhs_caf_attr;
1947
1948 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1949
1950 lhs_expr = code->ext.actual->expr;
1951 rhs_expr = code->ext.actual->next->expr;
1952 may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
1953 ? boolean_false_node : boolean_true_node;
1954 gfc_init_block (&block);
1955
1956 lhs_caf_attr = gfc_caf_attr (lhs_expr);
1957 rhs_caf_attr = gfc_caf_attr (rhs_expr);
1958 src_stat = dst_stat = null_pointer_node;
1959 dst_team = null_pointer_node;
1960
1961 /* LHS. */
1962 gfc_init_se (&lhs_se, NULL);
1963 if (lhs_expr->rank == 0)
1964 {
1965 if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
1966 {
1967 lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
1968 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1969 }
1970 else
1971 {
1972 symbol_attribute attr;
1973 gfc_clear_attr (&attr);
1974 gfc_conv_expr (&lhs_se, lhs_expr);
1975 lhs_type = TREE_TYPE (lhs_se.expr);
1976 lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
1977 attr);
1978 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1979 }
1980 }
1981 else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1982 && lhs_caf_attr.codimension)
1983 {
1984 lhs_se.want_pointer = 1;
1985 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1986 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1987 has the wrong type if component references are done. */
1988 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1989 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1990 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1991 gfc_get_dtype_rank_type (
1992 gfc_has_vector_subscript (lhs_expr)
1993 ? gfc_find_array_ref (lhs_expr)->dimen
1994 : lhs_expr->rank,
1995 lhs_type));
1996 }
1997 else
1998 {
1999 bool has_vector = gfc_has_vector_subscript (lhs_expr);
2000
2001 if (gfc_is_coindexed (lhs_expr) || !has_vector)
2002 {
2003 /* If has_vector, pass descriptor for whole array and the
2004 vector bounds separately. */
2005 gfc_array_ref *ar, ar2;
2006 bool has_tmp_lhs_array = false;
2007 if (has_vector)
2008 {
2009 has_tmp_lhs_array = true;
2010 ar = gfc_find_array_ref (lhs_expr);
2011 ar2 = *ar;
2012 memset (ar, '\0', sizeof (*ar));
2013 ar->as = ar2.as;
2014 ar->type = AR_FULL;
2015 }
2016 lhs_se.want_pointer = 1;
2017 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
2018 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2019 that has the wrong type if component references are done. */
2020 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2021 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
2022 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2023 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2024 : lhs_expr->rank,
2025 lhs_type));
2026 if (has_tmp_lhs_array)
2027 {
2028 vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
2029 *ar = ar2;
2030 }
2031 }
2032 else
2033 {
2034 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2035 indexed array expression. This is rewritten to:
2036
2037 tmp_array = arr2[...]
2038 arr1 ([...]) = tmp_array
2039
2040 because using the standard gfc_conv_expr (lhs_expr) did the
2041 assignment with lhs and rhs exchanged. */
2042
2043 gfc_ss *lss_for_tmparray, *lss_real;
2044 gfc_loopinfo loop;
2045 gfc_se se;
2046 stmtblock_t body;
2047 tree tmparr_desc, src;
2048 tree index = gfc_index_zero_node;
2049 tree stride = gfc_index_zero_node;
2050 int n;
2051
2052 /* Walk both sides of the assignment, once to get the shape of the
2053 temporary array to create right. */
2054 lss_for_tmparray = gfc_walk_expr (lhs_expr);
2055 /* And a second time to be able to create an assignment of the
2056 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2057 the tree in the descriptor with the one for the temporary
2058 array. */
2059 lss_real = gfc_walk_expr (lhs_expr);
2060 gfc_init_loopinfo (&loop);
2061 gfc_add_ss_to_loop (&loop, lss_for_tmparray);
2062 gfc_add_ss_to_loop (&loop, lss_real);
2063 gfc_conv_ss_startstride (&loop);
2064 gfc_conv_loop_setup (&loop, &lhs_expr->where);
2065 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2066 gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
2067 lss_for_tmparray, lhs_type, NULL_TREE,
2068 false, true, false,
2069 &lhs_expr->where);
2070 tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
2071 gfc_start_scalarized_body (&loop, &body);
2072 gfc_init_se (&se, NULL);
2073 gfc_copy_loopinfo_to_se (&se, &loop);
2074 se.ss = lss_real;
2075 gfc_conv_expr (&se, lhs_expr);
2076 gfc_add_block_to_block (&body, &se.pre);
2077
2078 /* Walk over all indexes of the loop. */
2079 for (n = loop.dimen - 1; n > 0; --n)
2080 {
2081 tmp = loop.loopvar[n];
2082 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2083 gfc_array_index_type, tmp, loop.from[n]);
2084 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2085 gfc_array_index_type, tmp, index);
2086
2087 stride = fold_build2_loc (input_location, MINUS_EXPR,
2088 gfc_array_index_type,
2089 loop.to[n - 1], loop.from[n - 1]);
2090 stride = fold_build2_loc (input_location, PLUS_EXPR,
2091 gfc_array_index_type,
2092 stride, gfc_index_one_node);
2093
2094 index = fold_build2_loc (input_location, MULT_EXPR,
2095 gfc_array_index_type, tmp, stride);
2096 }
2097
2098 index = fold_build2_loc (input_location, MINUS_EXPR,
2099 gfc_array_index_type,
2100 index, loop.from[0]);
2101
2102 index = fold_build2_loc (input_location, PLUS_EXPR,
2103 gfc_array_index_type,
2104 loop.loopvar[0], index);
2105
2106 src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
2107 src = gfc_build_array_ref (src, index, NULL);
2108 /* Now create the assignment of lhs_expr = tmp_array. */
2109 gfc_add_modify (&body, se.expr, src);
2110 gfc_add_block_to_block (&body, &se.post);
2111 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
2112 gfc_trans_scalarizing_loops (&loop, &body);
2113 gfc_add_block_to_block (&loop.pre, &loop.post);
2114 gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
2115 gfc_free_ss (lss_for_tmparray);
2116 gfc_free_ss (lss_real);
2117 }
2118 }
2119
2120 lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
2121
2122 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2123 temporary and a loop. */
2124 if (!gfc_is_coindexed (lhs_expr)
2125 && (!lhs_caf_attr.codimension
2126 || !(lhs_expr->rank > 0
2127 && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
2128 {
2129 bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
2130 gcc_assert (gfc_is_coindexed (rhs_expr));
2131 gfc_init_se (&rhs_se, NULL);
2132 if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
2133 {
2134 gfc_se scal_se;
2135 gfc_init_se (&scal_se, NULL);
2136 scal_se.want_pointer = 1;
2137 gfc_conv_expr (&scal_se, lhs_expr);
2138 /* Ensure scalar on lhs is allocated. */
2139 gfc_add_block_to_block (&block, &scal_se.pre);
2140
2141 gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
2142 TYPE_SIZE_UNIT (
2143 gfc_typenode_for_spec (&lhs_expr->ts)),
2144 NULL_TREE);
2145 tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
2146 null_pointer_node);
2147 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2148 tmp, gfc_finish_block (&scal_se.pre),
2149 build_empty_stmt (input_location));
2150 gfc_add_expr_to_block (&block, tmp);
2151 }
2152 else
2153 lhs_may_realloc = lhs_may_realloc
2154 && gfc_full_array_ref_p (lhs_expr->ref, NULL);
2155 gfc_add_block_to_block (&block, &lhs_se.pre);
2156 gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
2157 may_require_tmp, lhs_may_realloc,
2158 &rhs_caf_attr);
2159 gfc_add_block_to_block (&block, &rhs_se.pre);
2160 gfc_add_block_to_block (&block, &rhs_se.post);
2161 gfc_add_block_to_block (&block, &lhs_se.post);
2162 return gfc_finish_block (&block);
2163 }
2164
2165 gfc_add_block_to_block (&block, &lhs_se.pre);
2166
2167 /* Obtain token, offset and image index for the LHS. */
2168 caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
2169 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2170 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2171 image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
2172 tmp = lhs_se.expr;
2173 if (lhs_caf_attr.alloc_comp)
2174 gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
2175 NULL);
2176 else
2177 gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
2178 lhs_expr);
2179 lhs_se.expr = tmp;
2180
2181 /* RHS. */
2182 gfc_init_se (&rhs_se, NULL);
2183 if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
2184 && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
2185 rhs_expr = rhs_expr->value.function.actual->expr;
2186 if (rhs_expr->rank == 0)
2187 {
2188 symbol_attribute attr;
2189 gfc_clear_attr (&attr);
2190 gfc_conv_expr (&rhs_se, rhs_expr);
2191 rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2192 rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
2193 }
2194 else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2195 && rhs_caf_attr.codimension)
2196 {
2197 tree tmp2;
2198 rhs_se.want_pointer = 1;
2199 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2200 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2201 has the wrong type if component references are done. */
2202 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2203 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2204 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2205 gfc_get_dtype_rank_type (
2206 gfc_has_vector_subscript (rhs_expr)
2207 ? gfc_find_array_ref (rhs_expr)->dimen
2208 : rhs_expr->rank,
2209 tmp2));
2210 }
2211 else
2212 {
2213 /* If has_vector, pass descriptor for whole array and the
2214 vector bounds separately. */
2215 gfc_array_ref *ar, ar2;
2216 bool has_vector = false;
2217 tree tmp2;
2218
2219 if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2220 {
2221 has_vector = true;
2222 ar = gfc_find_array_ref (rhs_expr);
2223 ar2 = *ar;
2224 memset (ar, '\0', sizeof (*ar));
2225 ar->as = ar2.as;
2226 ar->type = AR_FULL;
2227 }
2228 rhs_se.want_pointer = 1;
2229 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2230 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2231 has the wrong type if component references are done. */
2232 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2233 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2234 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2235 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2236 : rhs_expr->rank,
2237 tmp2));
2238 if (has_vector)
2239 {
2240 rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
2241 *ar = ar2;
2242 }
2243 }
2244
2245 gfc_add_block_to_block (&block, &rhs_se.pre);
2246
2247 rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
2248
2249 tmp_stat = gfc_find_stat_co (lhs_expr);
2250
2251 if (tmp_stat)
2252 {
2253 gfc_se stat_se;
2254 gfc_init_se (&stat_se, NULL);
2255 gfc_conv_expr_reference (&stat_se, tmp_stat);
2256 dst_stat = stat_se.expr;
2257 gfc_add_block_to_block (&block, &stat_se.pre);
2258 gfc_add_block_to_block (&block, &stat_se.post);
2259 }
2260
2261 tmp_team = gfc_find_team_co (lhs_expr);
2262
2263 if (tmp_team)
2264 {
2265 gfc_se team_se;
2266 gfc_init_se (&team_se, NULL);
2267 gfc_conv_expr_reference (&team_se, tmp_team);
2268 dst_team = team_se.expr;
2269 gfc_add_block_to_block (&block, &team_se.pre);
2270 gfc_add_block_to_block (&block, &team_se.post);
2271 }
2272
2273 if (!gfc_is_coindexed (rhs_expr))
2274 {
2275 if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2276 {
2277 tree reference, dst_realloc;
2278 reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2279 dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
2280 : boolean_false_node;
2281 tmp = build_call_expr_loc (input_location,
2282 gfor_fndecl_caf_send_by_ref,
2283 10, token, image_index, rhs_se.expr,
2284 reference, lhs_kind, rhs_kind,
2285 may_require_tmp, dst_realloc, src_stat,
2286 build_int_cst (integer_type_node,
2287 lhs_expr->ts.type));
2288 }
2289 else
2290 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
2291 token, offset, image_index, lhs_se.expr, vec,
2292 rhs_se.expr, lhs_kind, rhs_kind,
2293 may_require_tmp, src_stat, dst_team);
2294 }
2295 else
2296 {
2297 tree rhs_token, rhs_offset, rhs_image_index;
2298
2299 /* It guarantees memory consistency within the same segment. */
2300 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2301 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2302 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2303 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2304 ASM_VOLATILE_P (tmp) = 1;
2305 gfc_add_expr_to_block (&block, tmp);
2306
2307 caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2308 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2309 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2310 rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2311 tmp = rhs_se.expr;
2312 if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2313 {
2314 tmp_stat = gfc_find_stat_co (lhs_expr);
2315
2316 if (tmp_stat)
2317 {
2318 gfc_se stat_se;
2319 gfc_init_se (&stat_se, NULL);
2320 gfc_conv_expr_reference (&stat_se, tmp_stat);
2321 src_stat = stat_se.expr;
2322 gfc_add_block_to_block (&block, &stat_se.pre);
2323 gfc_add_block_to_block (&block, &stat_se.post);
2324 }
2325
2326 gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
2327 NULL_TREE, NULL);
2328 tree lhs_reference, rhs_reference;
2329 lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2330 rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
2331 tmp = build_call_expr_loc (input_location,
2332 gfor_fndecl_caf_sendget_by_ref, 13,
2333 token, image_index, lhs_reference,
2334 rhs_token, rhs_image_index, rhs_reference,
2335 lhs_kind, rhs_kind, may_require_tmp,
2336 dst_stat, src_stat,
2337 build_int_cst (integer_type_node,
2338 lhs_expr->ts.type),
2339 build_int_cst (integer_type_node,
2340 rhs_expr->ts.type));
2341 }
2342 else
2343 {
2344 gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2345 tmp, rhs_expr);
2346 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2347 14, token, offset, image_index,
2348 lhs_se.expr, vec, rhs_token, rhs_offset,
2349 rhs_image_index, tmp, rhs_vec, lhs_kind,
2350 rhs_kind, may_require_tmp, src_stat);
2351 }
2352 }
2353 gfc_add_expr_to_block (&block, tmp);
2354 gfc_add_block_to_block (&block, &lhs_se.post);
2355 gfc_add_block_to_block (&block, &rhs_se.post);
2356
2357 /* It guarantees memory consistency within the same segment. */
2358 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2359 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2360 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2361 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2362 ASM_VOLATILE_P (tmp) = 1;
2363 gfc_add_expr_to_block (&block, tmp);
2364
2365 return gfc_finish_block (&block);
2366 }
2367
2368
2369 static void
trans_this_image(gfc_se * se,gfc_expr * expr)2370 trans_this_image (gfc_se * se, gfc_expr *expr)
2371 {
2372 stmtblock_t loop;
2373 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2374 lbound, ubound, extent, ml;
2375 gfc_se argse;
2376 int rank, corank;
2377 gfc_expr *distance = expr->value.function.actual->next->next->expr;
2378
2379 if (expr->value.function.actual->expr
2380 && !gfc_is_coarray (expr->value.function.actual->expr))
2381 distance = expr->value.function.actual->expr;
2382
2383 /* The case -fcoarray=single is handled elsewhere. */
2384 gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
2385
2386 /* Argument-free version: THIS_IMAGE(). */
2387 if (distance || expr->value.function.actual->expr == NULL)
2388 {
2389 if (distance)
2390 {
2391 gfc_init_se (&argse, NULL);
2392 gfc_conv_expr_val (&argse, distance);
2393 gfc_add_block_to_block (&se->pre, &argse.pre);
2394 gfc_add_block_to_block (&se->post, &argse.post);
2395 tmp = fold_convert (integer_type_node, argse.expr);
2396 }
2397 else
2398 tmp = integer_zero_node;
2399 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2400 tmp);
2401 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2402 tmp);
2403 return;
2404 }
2405
2406 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2407
2408 type = gfc_get_int_type (gfc_default_integer_kind);
2409 corank = gfc_get_corank (expr->value.function.actual->expr);
2410 rank = expr->value.function.actual->expr->rank;
2411
2412 /* Obtain the descriptor of the COARRAY. */
2413 gfc_init_se (&argse, NULL);
2414 argse.want_coarray = 1;
2415 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2416 gfc_add_block_to_block (&se->pre, &argse.pre);
2417 gfc_add_block_to_block (&se->post, &argse.post);
2418 desc = argse.expr;
2419
2420 if (se->ss)
2421 {
2422 /* Create an implicit second parameter from the loop variable. */
2423 gcc_assert (!expr->value.function.actual->next->expr);
2424 gcc_assert (corank > 0);
2425 gcc_assert (se->loop->dimen == 1);
2426 gcc_assert (se->ss->info->expr == expr);
2427
2428 dim_arg = se->loop->loopvar[0];
2429 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2430 gfc_array_index_type, dim_arg,
2431 build_int_cst (TREE_TYPE (dim_arg), 1));
2432 gfc_advance_se_ss_chain (se);
2433 }
2434 else
2435 {
2436 /* Use the passed DIM= argument. */
2437 gcc_assert (expr->value.function.actual->next->expr);
2438 gfc_init_se (&argse, NULL);
2439 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
2440 gfc_array_index_type);
2441 gfc_add_block_to_block (&se->pre, &argse.pre);
2442 dim_arg = argse.expr;
2443
2444 if (INTEGER_CST_P (dim_arg))
2445 {
2446 if (wi::ltu_p (wi::to_wide (dim_arg), 1)
2447 || wi::gtu_p (wi::to_wide (dim_arg),
2448 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2449 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2450 "dimension index", expr->value.function.isym->name,
2451 &expr->where);
2452 }
2453 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2454 {
2455 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2456 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2457 dim_arg,
2458 build_int_cst (TREE_TYPE (dim_arg), 1));
2459 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2460 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2461 dim_arg, tmp);
2462 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2463 logical_type_node, cond, tmp);
2464 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2465 gfc_msg_fault);
2466 }
2467 }
2468
2469 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2470 one always has a dim_arg argument.
2471
2472 m = this_image() - 1
2473 if (corank == 1)
2474 {
2475 sub(1) = m + lcobound(corank)
2476 return;
2477 }
2478 i = rank
2479 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2480 for (;;)
2481 {
2482 extent = gfc_extent(i)
2483 ml = m
2484 m = m/extent
2485 if (i >= min_var)
2486 goto exit_label
2487 i++
2488 }
2489 exit_label:
2490 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2491 : m + lcobound(corank)
2492 */
2493
2494 /* this_image () - 1. */
2495 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2496 integer_zero_node);
2497 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2498 fold_convert (type, tmp), build_int_cst (type, 1));
2499 if (corank == 1)
2500 {
2501 /* sub(1) = m + lcobound(corank). */
2502 lbound = gfc_conv_descriptor_lbound_get (desc,
2503 build_int_cst (TREE_TYPE (gfc_array_index_type),
2504 corank+rank-1));
2505 lbound = fold_convert (type, lbound);
2506 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2507
2508 se->expr = tmp;
2509 return;
2510 }
2511
2512 m = gfc_create_var (type, NULL);
2513 ml = gfc_create_var (type, NULL);
2514 loop_var = gfc_create_var (integer_type_node, NULL);
2515 min_var = gfc_create_var (integer_type_node, NULL);
2516
2517 /* m = this_image () - 1. */
2518 gfc_add_modify (&se->pre, m, tmp);
2519
2520 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2521 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2522 fold_convert (integer_type_node, dim_arg),
2523 build_int_cst (integer_type_node, rank - 1));
2524 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
2525 build_int_cst (integer_type_node, rank + corank - 2),
2526 tmp);
2527 gfc_add_modify (&se->pre, min_var, tmp);
2528
2529 /* i = rank. */
2530 tmp = build_int_cst (integer_type_node, rank);
2531 gfc_add_modify (&se->pre, loop_var, tmp);
2532
2533 exit_label = gfc_build_label_decl (NULL_TREE);
2534 TREE_USED (exit_label) = 1;
2535
2536 /* Loop body. */
2537 gfc_init_block (&loop);
2538
2539 /* ml = m. */
2540 gfc_add_modify (&loop, ml, m);
2541
2542 /* extent = ... */
2543 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2544 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2545 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2546 extent = fold_convert (type, extent);
2547
2548 /* m = m/extent. */
2549 gfc_add_modify (&loop, m,
2550 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2551 m, extent));
2552
2553 /* Exit condition: if (i >= min_var) goto exit_label. */
2554 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2555 min_var);
2556 tmp = build1_v (GOTO_EXPR, exit_label);
2557 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2558 build_empty_stmt (input_location));
2559 gfc_add_expr_to_block (&loop, tmp);
2560
2561 /* Increment loop variable: i++. */
2562 gfc_add_modify (&loop, loop_var,
2563 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2564 loop_var,
2565 build_int_cst (integer_type_node, 1)));
2566
2567 /* Making the loop... actually loop! */
2568 tmp = gfc_finish_block (&loop);
2569 tmp = build1_v (LOOP_EXPR, tmp);
2570 gfc_add_expr_to_block (&se->pre, tmp);
2571
2572 /* The exit label. */
2573 tmp = build1_v (LABEL_EXPR, exit_label);
2574 gfc_add_expr_to_block (&se->pre, tmp);
2575
2576 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2577 : m + lcobound(corank) */
2578
2579 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2580 build_int_cst (TREE_TYPE (dim_arg), corank));
2581
2582 lbound = gfc_conv_descriptor_lbound_get (desc,
2583 fold_build2_loc (input_location, PLUS_EXPR,
2584 gfc_array_index_type, dim_arg,
2585 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2586 lbound = fold_convert (type, lbound);
2587
2588 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2589 fold_build2_loc (input_location, MULT_EXPR, type,
2590 m, extent));
2591 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2592
2593 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2594 fold_build2_loc (input_location, PLUS_EXPR, type,
2595 m, lbound));
2596 }
2597
2598
2599 /* Convert a call to image_status. */
2600
2601 static void
conv_intrinsic_image_status(gfc_se * se,gfc_expr * expr)2602 conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2603 {
2604 unsigned int num_args;
2605 tree *args, tmp;
2606
2607 num_args = gfc_intrinsic_argument_list_length (expr);
2608 args = XALLOCAVEC (tree, num_args);
2609 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2610 /* In args[0] the number of the image the status is desired for has to be
2611 given. */
2612
2613 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2614 {
2615 tree arg;
2616 arg = gfc_evaluate_now (args[0], &se->pre);
2617 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2618 fold_convert (integer_type_node, arg),
2619 integer_one_node);
2620 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2621 tmp, integer_zero_node,
2622 build_int_cst (integer_type_node,
2623 GFC_STAT_STOPPED_IMAGE));
2624 }
2625 else if (flag_coarray == GFC_FCOARRAY_LIB)
2626 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2627 args[0], build_int_cst (integer_type_node, -1));
2628 else
2629 gcc_unreachable ();
2630
2631 se->expr = tmp;
2632 }
2633
2634 static void
conv_intrinsic_team_number(gfc_se * se,gfc_expr * expr)2635 conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2636 {
2637 unsigned int num_args;
2638
2639 tree *args, tmp;
2640
2641 num_args = gfc_intrinsic_argument_list_length (expr);
2642 args = XALLOCAVEC (tree, num_args);
2643 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2644
2645 if (flag_coarray ==
2646 GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2647 {
2648 tree arg;
2649
2650 arg = gfc_evaluate_now (args[0], &se->pre);
2651 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2652 fold_convert (integer_type_node, arg),
2653 integer_one_node);
2654 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2655 tmp, integer_zero_node,
2656 build_int_cst (integer_type_node,
2657 GFC_STAT_STOPPED_IMAGE));
2658 }
2659 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2660 {
2661 // the value -1 represents that no team has been created yet
2662 tmp = build_int_cst (integer_type_node, -1);
2663 }
2664 else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2665 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2666 args[0], build_int_cst (integer_type_node, -1));
2667 else if (flag_coarray == GFC_FCOARRAY_LIB)
2668 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2669 integer_zero_node, build_int_cst (integer_type_node, -1));
2670 else
2671 gcc_unreachable ();
2672
2673 se->expr = tmp;
2674 }
2675
2676
2677 static void
trans_image_index(gfc_se * se,gfc_expr * expr)2678 trans_image_index (gfc_se * se, gfc_expr *expr)
2679 {
2680 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2681 tmp, invalid_bound;
2682 gfc_se argse, subse;
2683 int rank, corank, codim;
2684
2685 type = gfc_get_int_type (gfc_default_integer_kind);
2686 corank = gfc_get_corank (expr->value.function.actual->expr);
2687 rank = expr->value.function.actual->expr->rank;
2688
2689 /* Obtain the descriptor of the COARRAY. */
2690 gfc_init_se (&argse, NULL);
2691 argse.want_coarray = 1;
2692 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2693 gfc_add_block_to_block (&se->pre, &argse.pre);
2694 gfc_add_block_to_block (&se->post, &argse.post);
2695 desc = argse.expr;
2696
2697 /* Obtain a handle to the SUB argument. */
2698 gfc_init_se (&subse, NULL);
2699 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2700 gfc_add_block_to_block (&se->pre, &subse.pre);
2701 gfc_add_block_to_block (&se->post, &subse.post);
2702 subdesc = build_fold_indirect_ref_loc (input_location,
2703 gfc_conv_descriptor_data_get (subse.expr));
2704
2705 /* Fortran 2008 does not require that the values remain in the cobounds,
2706 thus we need explicitly check this - and return 0 if they are exceeded. */
2707
2708 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2709 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2710 invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2711 fold_convert (gfc_array_index_type, tmp),
2712 lbound);
2713
2714 for (codim = corank + rank - 2; codim >= rank; codim--)
2715 {
2716 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2717 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2718 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2719 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2720 fold_convert (gfc_array_index_type, tmp),
2721 lbound);
2722 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2723 logical_type_node, invalid_bound, cond);
2724 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2725 fold_convert (gfc_array_index_type, tmp),
2726 ubound);
2727 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2728 logical_type_node, invalid_bound, cond);
2729 }
2730
2731 invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2732
2733 /* See Fortran 2008, C.10 for the following algorithm. */
2734
2735 /* coindex = sub(corank) - lcobound(n). */
2736 coindex = fold_convert (gfc_array_index_type,
2737 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2738 NULL));
2739 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2740 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2741 fold_convert (gfc_array_index_type, coindex),
2742 lbound);
2743
2744 for (codim = corank + rank - 2; codim >= rank; codim--)
2745 {
2746 tree extent, ubound;
2747
2748 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2749 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2750 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2751 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2752
2753 /* coindex *= extent. */
2754 coindex = fold_build2_loc (input_location, MULT_EXPR,
2755 gfc_array_index_type, coindex, extent);
2756
2757 /* coindex += sub(codim). */
2758 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2759 coindex = fold_build2_loc (input_location, PLUS_EXPR,
2760 gfc_array_index_type, coindex,
2761 fold_convert (gfc_array_index_type, tmp));
2762
2763 /* coindex -= lbound(codim). */
2764 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2765 coindex = fold_build2_loc (input_location, MINUS_EXPR,
2766 gfc_array_index_type, coindex, lbound);
2767 }
2768
2769 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2770 fold_convert(type, coindex),
2771 build_int_cst (type, 1));
2772
2773 /* Return 0 if "coindex" exceeds num_images(). */
2774
2775 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2776 num_images = build_int_cst (type, 1);
2777 else
2778 {
2779 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2780 integer_zero_node,
2781 build_int_cst (integer_type_node, -1));
2782 num_images = fold_convert (type, tmp);
2783 }
2784
2785 tmp = gfc_create_var (type, NULL);
2786 gfc_add_modify (&se->pre, tmp, coindex);
2787
2788 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2789 num_images);
2790 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2791 cond,
2792 fold_convert (logical_type_node, invalid_bound));
2793 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2794 build_int_cst (type, 0), tmp);
2795 }
2796
2797 static void
trans_num_images(gfc_se * se,gfc_expr * expr)2798 trans_num_images (gfc_se * se, gfc_expr *expr)
2799 {
2800 tree tmp, distance, failed;
2801 gfc_se argse;
2802
2803 if (expr->value.function.actual->expr)
2804 {
2805 gfc_init_se (&argse, NULL);
2806 gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2807 gfc_add_block_to_block (&se->pre, &argse.pre);
2808 gfc_add_block_to_block (&se->post, &argse.post);
2809 distance = fold_convert (integer_type_node, argse.expr);
2810 }
2811 else
2812 distance = integer_zero_node;
2813
2814 if (expr->value.function.actual->next->expr)
2815 {
2816 gfc_init_se (&argse, NULL);
2817 gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2818 gfc_add_block_to_block (&se->pre, &argse.pre);
2819 gfc_add_block_to_block (&se->post, &argse.post);
2820 failed = fold_convert (integer_type_node, argse.expr);
2821 }
2822 else
2823 failed = build_int_cst (integer_type_node, -1);
2824 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2825 distance, failed);
2826 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2827 }
2828
2829
2830 static void
gfc_conv_intrinsic_rank(gfc_se * se,gfc_expr * expr)2831 gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2832 {
2833 gfc_se argse;
2834
2835 gfc_init_se (&argse, NULL);
2836 argse.data_not_needed = 1;
2837 argse.descriptor_only = 1;
2838
2839 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2840 gfc_add_block_to_block (&se->pre, &argse.pre);
2841 gfc_add_block_to_block (&se->post, &argse.post);
2842
2843 se->expr = gfc_conv_descriptor_rank (argse.expr);
2844 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2845 se->expr);
2846 }
2847
2848
2849 static void
gfc_conv_intrinsic_is_contiguous(gfc_se * se,gfc_expr * expr)2850 gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2851 {
2852 gfc_expr *arg;
2853 arg = expr->value.function.actual->expr;
2854 gfc_conv_is_contiguous_expr (se, arg);
2855 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2856 }
2857
2858 /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2859 plus it can be called directly. */
2860
2861 void
gfc_conv_is_contiguous_expr(gfc_se * se,gfc_expr * arg)2862 gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2863 {
2864 gfc_ss *ss;
2865 gfc_se argse;
2866 tree desc, tmp, stride, extent, cond;
2867 int i;
2868 tree fncall0;
2869 gfc_array_spec *as;
2870
2871 if (arg->ts.type == BT_CLASS)
2872 gfc_add_class_array_ref (arg);
2873
2874 ss = gfc_walk_expr (arg);
2875 gcc_assert (ss != gfc_ss_terminator);
2876 gfc_init_se (&argse, NULL);
2877 argse.data_not_needed = 1;
2878 gfc_conv_expr_descriptor (&argse, arg);
2879
2880 as = gfc_get_full_arrayspec_from_expr (arg);
2881
2882 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2883 Note in addition that zero-sized arrays don't count as contiguous. */
2884
2885 if (as && as->type == AS_ASSUMED_RANK)
2886 {
2887 /* Build the call to is_contiguous0. */
2888 argse.want_pointer = 1;
2889 gfc_conv_expr_descriptor (&argse, arg);
2890 gfc_add_block_to_block (&se->pre, &argse.pre);
2891 gfc_add_block_to_block (&se->post, &argse.post);
2892 desc = gfc_evaluate_now (argse.expr, &se->pre);
2893 fncall0 = build_call_expr_loc (input_location,
2894 gfor_fndecl_is_contiguous0, 1, desc);
2895 se->expr = fncall0;
2896 se->expr = convert (logical_type_node, se->expr);
2897 }
2898 else
2899 {
2900 gfc_add_block_to_block (&se->pre, &argse.pre);
2901 gfc_add_block_to_block (&se->post, &argse.post);
2902 desc = gfc_evaluate_now (argse.expr, &se->pre);
2903
2904 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2905 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2906 stride, build_int_cst (TREE_TYPE (stride), 1));
2907
2908 for (i = 0; i < arg->rank - 1; i++)
2909 {
2910 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2911 extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2912 extent = fold_build2_loc (input_location, MINUS_EXPR,
2913 gfc_array_index_type, extent, tmp);
2914 extent = fold_build2_loc (input_location, PLUS_EXPR,
2915 gfc_array_index_type, extent,
2916 gfc_index_one_node);
2917 tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2918 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2919 tmp, extent);
2920 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2921 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2922 stride, tmp);
2923 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2924 boolean_type_node, cond, tmp);
2925 }
2926 se->expr = cond;
2927 }
2928 }
2929
2930
2931 /* Evaluate a single upper or lower bound. */
2932 /* TODO: bound intrinsic generates way too much unnecessary code. */
2933
2934 static void
gfc_conv_intrinsic_bound(gfc_se * se,gfc_expr * expr,int upper)2935 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
2936 {
2937 gfc_actual_arglist *arg;
2938 gfc_actual_arglist *arg2;
2939 tree desc;
2940 tree type;
2941 tree bound;
2942 tree tmp;
2943 tree cond, cond1, cond3, cond4, size;
2944 tree ubound;
2945 tree lbound;
2946 gfc_se argse;
2947 gfc_array_spec * as;
2948 bool assumed_rank_lb_one;
2949
2950 arg = expr->value.function.actual;
2951 arg2 = arg->next;
2952
2953 if (se->ss)
2954 {
2955 /* Create an implicit second parameter from the loop variable. */
2956 gcc_assert (!arg2->expr);
2957 gcc_assert (se->loop->dimen == 1);
2958 gcc_assert (se->ss->info->expr == expr);
2959 gfc_advance_se_ss_chain (se);
2960 bound = se->loop->loopvar[0];
2961 bound = fold_build2_loc (input_location, MINUS_EXPR,
2962 gfc_array_index_type, bound,
2963 se->loop->from[0]);
2964 }
2965 else
2966 {
2967 /* use the passed argument. */
2968 gcc_assert (arg2->expr);
2969 gfc_init_se (&argse, NULL);
2970 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2971 gfc_add_block_to_block (&se->pre, &argse.pre);
2972 bound = argse.expr;
2973 /* Convert from one based to zero based. */
2974 bound = fold_build2_loc (input_location, MINUS_EXPR,
2975 gfc_array_index_type, bound,
2976 gfc_index_one_node);
2977 }
2978
2979 /* TODO: don't re-evaluate the descriptor on each iteration. */
2980 /* Get a descriptor for the first parameter. */
2981 gfc_init_se (&argse, NULL);
2982 gfc_conv_expr_descriptor (&argse, arg->expr);
2983 gfc_add_block_to_block (&se->pre, &argse.pre);
2984 gfc_add_block_to_block (&se->post, &argse.post);
2985
2986 desc = argse.expr;
2987
2988 as = gfc_get_full_arrayspec_from_expr (arg->expr);
2989
2990 if (INTEGER_CST_P (bound))
2991 {
2992 if (((!as || as->type != AS_ASSUMED_RANK)
2993 && wi::geu_p (wi::to_wide (bound),
2994 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2995 || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2996 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2997 "dimension index", upper ? "UBOUND" : "LBOUND",
2998 &expr->where);
2999 }
3000
3001 if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
3002 {
3003 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3004 {
3005 bound = gfc_evaluate_now (bound, &se->pre);
3006 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3007 bound, build_int_cst (TREE_TYPE (bound), 0));
3008 if (as && as->type == AS_ASSUMED_RANK)
3009 tmp = gfc_conv_descriptor_rank (desc);
3010 else
3011 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
3012 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3013 bound, fold_convert(TREE_TYPE (bound), tmp));
3014 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3015 logical_type_node, cond, tmp);
3016 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3017 gfc_msg_fault);
3018 }
3019 }
3020
3021 /* Take care of the lbound shift for assumed-rank arrays, which are
3022 nonallocatable and nonpointers. Those has a lbound of 1. */
3023 assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
3024 && ((arg->expr->ts.type != BT_CLASS
3025 && !arg->expr->symtree->n.sym->attr.allocatable
3026 && !arg->expr->symtree->n.sym->attr.pointer)
3027 || (arg->expr->ts.type == BT_CLASS
3028 && !CLASS_DATA (arg->expr)->attr.allocatable
3029 && !CLASS_DATA (arg->expr)->attr.class_pointer));
3030
3031 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
3032 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
3033
3034 /* 13.14.53: Result value for LBOUND
3035
3036 Case (i): For an array section or for an array expression other than a
3037 whole array or array structure component, LBOUND(ARRAY, DIM)
3038 has the value 1. For a whole array or array structure
3039 component, LBOUND(ARRAY, DIM) has the value:
3040 (a) equal to the lower bound for subscript DIM of ARRAY if
3041 dimension DIM of ARRAY does not have extent zero
3042 or if ARRAY is an assumed-size array of rank DIM,
3043 or (b) 1 otherwise.
3044
3045 13.14.113: Result value for UBOUND
3046
3047 Case (i): For an array section or for an array expression other than a
3048 whole array or array structure component, UBOUND(ARRAY, DIM)
3049 has the value equal to the number of elements in the given
3050 dimension; otherwise, it has a value equal to the upper bound
3051 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3052 not have size zero and has value zero if dimension DIM has
3053 size zero. */
3054
3055 if (!upper && assumed_rank_lb_one)
3056 se->expr = gfc_index_one_node;
3057 else if (as)
3058 {
3059 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
3060
3061 cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3062 ubound, lbound);
3063 cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3064 stride, gfc_index_zero_node);
3065 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3066 logical_type_node, cond3, cond1);
3067 cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3068 stride, gfc_index_zero_node);
3069
3070 if (upper)
3071 {
3072 tree cond5;
3073 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3074 logical_type_node, cond3, cond4);
3075 cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3076 gfc_index_one_node, lbound);
3077 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3078 logical_type_node, cond4, cond5);
3079
3080 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3081 logical_type_node, cond, cond5);
3082
3083 if (assumed_rank_lb_one)
3084 {
3085 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3086 gfc_array_index_type, ubound, lbound);
3087 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3088 gfc_array_index_type, tmp, gfc_index_one_node);
3089 }
3090 else
3091 tmp = ubound;
3092
3093 se->expr = fold_build3_loc (input_location, COND_EXPR,
3094 gfc_array_index_type, cond,
3095 tmp, gfc_index_zero_node);
3096 }
3097 else
3098 {
3099 if (as->type == AS_ASSUMED_SIZE)
3100 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3101 bound, build_int_cst (TREE_TYPE (bound),
3102 arg->expr->rank - 1));
3103 else
3104 cond = logical_false_node;
3105
3106 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3107 logical_type_node, cond3, cond4);
3108 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3109 logical_type_node, cond, cond1);
3110
3111 se->expr = fold_build3_loc (input_location, COND_EXPR,
3112 gfc_array_index_type, cond,
3113 lbound, gfc_index_one_node);
3114 }
3115 }
3116 else
3117 {
3118 if (upper)
3119 {
3120 size = fold_build2_loc (input_location, MINUS_EXPR,
3121 gfc_array_index_type, ubound, lbound);
3122 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
3123 gfc_array_index_type, size,
3124 gfc_index_one_node);
3125 se->expr = fold_build2_loc (input_location, MAX_EXPR,
3126 gfc_array_index_type, se->expr,
3127 gfc_index_zero_node);
3128 }
3129 else
3130 se->expr = gfc_index_one_node;
3131 }
3132
3133 /* According to F2018 16.9.172, para 5, an assumed rank object, argument
3134 associated with and assumed size array, has the ubound of the final
3135 dimension set to -1 and UBOUND must return this. */
3136 if (upper && as && as->type == AS_ASSUMED_RANK)
3137 {
3138 tree minus_one = build_int_cst (gfc_array_index_type, -1);
3139 tree rank = fold_convert (gfc_array_index_type,
3140 gfc_conv_descriptor_rank (desc));
3141 rank = fold_build2_loc (input_location, PLUS_EXPR,
3142 gfc_array_index_type, rank, minus_one);
3143 /* Fix the expression to stop it from becoming even more complicated. */
3144 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3145 cond = fold_build2_loc (input_location, NE_EXPR,
3146 logical_type_node, bound, rank);
3147 cond1 = fold_build2_loc (input_location, NE_EXPR,
3148 logical_type_node, ubound, minus_one);
3149 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3150 logical_type_node, cond, cond1);
3151 se->expr = fold_build3_loc (input_location, COND_EXPR,
3152 gfc_array_index_type, cond,
3153 se->expr, minus_one);
3154 }
3155
3156 type = gfc_typenode_for_spec (&expr->ts);
3157 se->expr = convert (type, se->expr);
3158 }
3159
3160
3161 static void
conv_intrinsic_cobound(gfc_se * se,gfc_expr * expr)3162 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
3163 {
3164 gfc_actual_arglist *arg;
3165 gfc_actual_arglist *arg2;
3166 gfc_se argse;
3167 tree bound, resbound, resbound2, desc, cond, tmp;
3168 tree type;
3169 int corank;
3170
3171 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
3172 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
3173 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
3174
3175 arg = expr->value.function.actual;
3176 arg2 = arg->next;
3177
3178 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
3179 corank = gfc_get_corank (arg->expr);
3180
3181 gfc_init_se (&argse, NULL);
3182 argse.want_coarray = 1;
3183
3184 gfc_conv_expr_descriptor (&argse, arg->expr);
3185 gfc_add_block_to_block (&se->pre, &argse.pre);
3186 gfc_add_block_to_block (&se->post, &argse.post);
3187 desc = argse.expr;
3188
3189 if (se->ss)
3190 {
3191 /* Create an implicit second parameter from the loop variable. */
3192 gcc_assert (!arg2->expr);
3193 gcc_assert (corank > 0);
3194 gcc_assert (se->loop->dimen == 1);
3195 gcc_assert (se->ss->info->expr == expr);
3196
3197 bound = se->loop->loopvar[0];
3198 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3199 bound, gfc_rank_cst[arg->expr->rank]);
3200 gfc_advance_se_ss_chain (se);
3201 }
3202 else
3203 {
3204 /* use the passed argument. */
3205 gcc_assert (arg2->expr);
3206 gfc_init_se (&argse, NULL);
3207 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
3208 gfc_add_block_to_block (&se->pre, &argse.pre);
3209 bound = argse.expr;
3210
3211 if (INTEGER_CST_P (bound))
3212 {
3213 if (wi::ltu_p (wi::to_wide (bound), 1)
3214 || wi::gtu_p (wi::to_wide (bound),
3215 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
3216 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3217 "dimension index", expr->value.function.isym->name,
3218 &expr->where);
3219 }
3220 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3221 {
3222 bound = gfc_evaluate_now (bound, &se->pre);
3223 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3224 bound, build_int_cst (TREE_TYPE (bound), 1));
3225 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
3226 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3227 bound, tmp);
3228 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3229 logical_type_node, cond, tmp);
3230 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3231 gfc_msg_fault);
3232 }
3233
3234
3235 /* Subtract 1 to get to zero based and add dimensions. */
3236 switch (arg->expr->rank)
3237 {
3238 case 0:
3239 bound = fold_build2_loc (input_location, MINUS_EXPR,
3240 gfc_array_index_type, bound,
3241 gfc_index_one_node);
3242 case 1:
3243 break;
3244 default:
3245 bound = fold_build2_loc (input_location, PLUS_EXPR,
3246 gfc_array_index_type, bound,
3247 gfc_rank_cst[arg->expr->rank - 1]);
3248 }
3249 }
3250
3251 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
3252
3253 /* Handle UCOBOUND with special handling of the last codimension. */
3254 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
3255 {
3256 /* Last codimension: For -fcoarray=single just return
3257 the lcobound - otherwise add
3258 ceiling (real (num_images ()) / real (size)) - 1
3259 = (num_images () + size - 1) / size - 1
3260 = (num_images - 1) / size(),
3261 where size is the product of the extent of all but the last
3262 codimension. */
3263
3264 if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
3265 {
3266 tree cosize;
3267
3268 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
3269 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3270 2, integer_zero_node,
3271 build_int_cst (integer_type_node, -1));
3272 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3273 gfc_array_index_type,
3274 fold_convert (gfc_array_index_type, tmp),
3275 build_int_cst (gfc_array_index_type, 1));
3276 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
3277 gfc_array_index_type, tmp,
3278 fold_convert (gfc_array_index_type, cosize));
3279 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3280 gfc_array_index_type, resbound, tmp);
3281 }
3282 else if (flag_coarray != GFC_FCOARRAY_SINGLE)
3283 {
3284 /* ubound = lbound + num_images() - 1. */
3285 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3286 2, integer_zero_node,
3287 build_int_cst (integer_type_node, -1));
3288 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3289 gfc_array_index_type,
3290 fold_convert (gfc_array_index_type, tmp),
3291 build_int_cst (gfc_array_index_type, 1));
3292 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3293 gfc_array_index_type, resbound, tmp);
3294 }
3295
3296 if (corank > 1)
3297 {
3298 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3299 bound,
3300 build_int_cst (TREE_TYPE (bound),
3301 arg->expr->rank + corank - 1));
3302
3303 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
3304 se->expr = fold_build3_loc (input_location, COND_EXPR,
3305 gfc_array_index_type, cond,
3306 resbound, resbound2);
3307 }
3308 else
3309 se->expr = resbound;
3310 }
3311 else
3312 se->expr = resbound;
3313
3314 type = gfc_typenode_for_spec (&expr->ts);
3315 se->expr = convert (type, se->expr);
3316 }
3317
3318
3319 static void
conv_intrinsic_stride(gfc_se * se,gfc_expr * expr)3320 conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
3321 {
3322 gfc_actual_arglist *array_arg;
3323 gfc_actual_arglist *dim_arg;
3324 gfc_se argse;
3325 tree desc, tmp;
3326
3327 array_arg = expr->value.function.actual;
3328 dim_arg = array_arg->next;
3329
3330 gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
3331
3332 gfc_init_se (&argse, NULL);
3333 gfc_conv_expr_descriptor (&argse, array_arg->expr);
3334 gfc_add_block_to_block (&se->pre, &argse.pre);
3335 gfc_add_block_to_block (&se->post, &argse.post);
3336 desc = argse.expr;
3337
3338 gcc_assert (dim_arg->expr);
3339 gfc_init_se (&argse, NULL);
3340 gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
3341 gfc_add_block_to_block (&se->pre, &argse.pre);
3342 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3343 argse.expr, gfc_index_one_node);
3344 se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
3345 }
3346
3347 static void
gfc_conv_intrinsic_abs(gfc_se * se,gfc_expr * expr)3348 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
3349 {
3350 tree arg, cabs;
3351
3352 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3353
3354 switch (expr->value.function.actual->expr->ts.type)
3355 {
3356 case BT_INTEGER:
3357 case BT_REAL:
3358 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
3359 arg);
3360 break;
3361
3362 case BT_COMPLEX:
3363 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
3364 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
3365 break;
3366
3367 default:
3368 gcc_unreachable ();
3369 }
3370 }
3371
3372
3373 /* Create a complex value from one or two real components. */
3374
3375 static void
gfc_conv_intrinsic_cmplx(gfc_se * se,gfc_expr * expr,int both)3376 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
3377 {
3378 tree real;
3379 tree imag;
3380 tree type;
3381 tree *args;
3382 unsigned int num_args;
3383
3384 num_args = gfc_intrinsic_argument_list_length (expr);
3385 args = XALLOCAVEC (tree, num_args);
3386
3387 type = gfc_typenode_for_spec (&expr->ts);
3388 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3389 real = convert (TREE_TYPE (type), args[0]);
3390 if (both)
3391 imag = convert (TREE_TYPE (type), args[1]);
3392 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
3393 {
3394 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3395 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
3396 imag = convert (TREE_TYPE (type), imag);
3397 }
3398 else
3399 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
3400
3401 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3402 }
3403
3404
3405 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3406 MODULO(A, P) = A - FLOOR (A / P) * P
3407
3408 The obvious algorithms above are numerically instable for large
3409 arguments, hence these intrinsics are instead implemented via calls
3410 to the fmod family of functions. It is the responsibility of the
3411 user to ensure that the second argument is non-zero. */
3412
3413 static void
gfc_conv_intrinsic_mod(gfc_se * se,gfc_expr * expr,int modulo)3414 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3415 {
3416 tree type;
3417 tree tmp;
3418 tree test;
3419 tree test2;
3420 tree fmod;
3421 tree zero;
3422 tree args[2];
3423
3424 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3425
3426 switch (expr->ts.type)
3427 {
3428 case BT_INTEGER:
3429 /* Integer case is easy, we've got a builtin op. */
3430 type = TREE_TYPE (args[0]);
3431
3432 if (modulo)
3433 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3434 args[0], args[1]);
3435 else
3436 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3437 args[0], args[1]);
3438 break;
3439
3440 case BT_REAL:
3441 fmod = NULL_TREE;
3442 /* Check if we have a builtin fmod. */
3443 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3444
3445 /* The builtin should always be available. */
3446 gcc_assert (fmod != NULL_TREE);
3447
3448 tmp = build_addr (fmod);
3449 se->expr = build_call_array_loc (input_location,
3450 TREE_TYPE (TREE_TYPE (fmod)),
3451 tmp, 2, args);
3452 if (modulo == 0)
3453 return;
3454
3455 type = TREE_TYPE (args[0]);
3456
3457 args[0] = gfc_evaluate_now (args[0], &se->pre);
3458 args[1] = gfc_evaluate_now (args[1], &se->pre);
3459
3460 /* Definition:
3461 modulo = arg - floor (arg/arg2) * arg2
3462
3463 In order to calculate the result accurately, we use the fmod
3464 function as follows.
3465
3466 res = fmod (arg, arg2);
3467 if (res)
3468 {
3469 if ((arg < 0) xor (arg2 < 0))
3470 res += arg2;
3471 }
3472 else
3473 res = copysign (0., arg2);
3474
3475 => As two nested ternary exprs:
3476
3477 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3478 : copysign (0., arg2);
3479
3480 */
3481
3482 zero = gfc_build_const (type, integer_zero_node);
3483 tmp = gfc_evaluate_now (se->expr, &se->pre);
3484 if (!flag_signed_zeros)
3485 {
3486 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3487 args[0], zero);
3488 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3489 args[1], zero);
3490 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3491 logical_type_node, test, test2);
3492 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3493 tmp, zero);
3494 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3495 logical_type_node, test, test2);
3496 test = gfc_evaluate_now (test, &se->pre);
3497 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3498 fold_build2_loc (input_location,
3499 PLUS_EXPR,
3500 type, tmp, args[1]),
3501 tmp);
3502 }
3503 else
3504 {
3505 tree expr1, copysign, cscall;
3506 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3507 expr->ts.kind);
3508 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3509 args[0], zero);
3510 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3511 args[1], zero);
3512 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3513 logical_type_node, test, test2);
3514 expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3515 fold_build2_loc (input_location,
3516 PLUS_EXPR,
3517 type, tmp, args[1]),
3518 tmp);
3519 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3520 tmp, zero);
3521 cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3522 args[1]);
3523 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3524 expr1, cscall);
3525 }
3526 return;
3527
3528 default:
3529 gcc_unreachable ();
3530 }
3531 }
3532
3533 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3534 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3535 where the right shifts are logical (i.e. 0's are shifted in).
3536 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3537 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3538 DSHIFTL(I,J,0) = I
3539 DSHIFTL(I,J,BITSIZE) = J
3540 DSHIFTR(I,J,0) = J
3541 DSHIFTR(I,J,BITSIZE) = I. */
3542
3543 static void
gfc_conv_intrinsic_dshift(gfc_se * se,gfc_expr * expr,bool dshiftl)3544 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3545 {
3546 tree type, utype, stype, arg1, arg2, shift, res, left, right;
3547 tree args[3], cond, tmp;
3548 int bitsize;
3549
3550 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3551
3552 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3553 type = TREE_TYPE (args[0]);
3554 bitsize = TYPE_PRECISION (type);
3555 utype = unsigned_type_for (type);
3556 stype = TREE_TYPE (args[2]);
3557
3558 arg1 = gfc_evaluate_now (args[0], &se->pre);
3559 arg2 = gfc_evaluate_now (args[1], &se->pre);
3560 shift = gfc_evaluate_now (args[2], &se->pre);
3561
3562 /* The generic case. */
3563 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3564 build_int_cst (stype, bitsize), shift);
3565 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3566 arg1, dshiftl ? shift : tmp);
3567
3568 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3569 fold_convert (utype, arg2), dshiftl ? tmp : shift);
3570 right = fold_convert (type, right);
3571
3572 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3573
3574 /* Special cases. */
3575 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3576 build_int_cst (stype, 0));
3577 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3578 dshiftl ? arg1 : arg2, res);
3579
3580 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3581 build_int_cst (stype, bitsize));
3582 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3583 dshiftl ? arg2 : arg1, res);
3584
3585 se->expr = res;
3586 }
3587
3588
3589 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3590
3591 static void
gfc_conv_intrinsic_dim(gfc_se * se,gfc_expr * expr)3592 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3593 {
3594 tree val;
3595 tree tmp;
3596 tree type;
3597 tree zero;
3598 tree args[2];
3599
3600 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3601 type = TREE_TYPE (args[0]);
3602
3603 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3604 val = gfc_evaluate_now (val, &se->pre);
3605
3606 zero = gfc_build_const (type, integer_zero_node);
3607 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3608 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3609 }
3610
3611
3612 /* SIGN(A, B) is absolute value of A times sign of B.
3613 The real value versions use library functions to ensure the correct
3614 handling of negative zero. Integer case implemented as:
3615 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3616 */
3617
3618 static void
gfc_conv_intrinsic_sign(gfc_se * se,gfc_expr * expr)3619 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3620 {
3621 tree tmp;
3622 tree type;
3623 tree args[2];
3624
3625 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3626 if (expr->ts.type == BT_REAL)
3627 {
3628 tree abs;
3629
3630 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3631 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3632
3633 /* We explicitly have to ignore the minus sign. We do so by using
3634 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3635 if (!flag_sign_zero
3636 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3637 {
3638 tree cond, zero;
3639 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3640 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3641 args[1], zero);
3642 se->expr = fold_build3_loc (input_location, COND_EXPR,
3643 TREE_TYPE (args[0]), cond,
3644 build_call_expr_loc (input_location, abs, 1,
3645 args[0]),
3646 build_call_expr_loc (input_location, tmp, 2,
3647 args[0], args[1]));
3648 }
3649 else
3650 se->expr = build_call_expr_loc (input_location, tmp, 2,
3651 args[0], args[1]);
3652 return;
3653 }
3654
3655 /* Having excluded floating point types, we know we are now dealing
3656 with signed integer types. */
3657 type = TREE_TYPE (args[0]);
3658
3659 /* Args[0] is used multiple times below. */
3660 args[0] = gfc_evaluate_now (args[0], &se->pre);
3661
3662 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3663 the signs of A and B are the same, and of all ones if they differ. */
3664 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3665 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3666 build_int_cst (type, TYPE_PRECISION (type) - 1));
3667 tmp = gfc_evaluate_now (tmp, &se->pre);
3668
3669 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3670 is all ones (i.e. -1). */
3671 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3672 fold_build2_loc (input_location, PLUS_EXPR,
3673 type, args[0], tmp), tmp);
3674 }
3675
3676
3677 /* Test for the presence of an optional argument. */
3678
3679 static void
gfc_conv_intrinsic_present(gfc_se * se,gfc_expr * expr)3680 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3681 {
3682 gfc_expr *arg;
3683
3684 arg = expr->value.function.actual->expr;
3685 gcc_assert (arg->expr_type == EXPR_VARIABLE);
3686 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3687 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3688 }
3689
3690
3691 /* Calculate the double precision product of two single precision values. */
3692
3693 static void
gfc_conv_intrinsic_dprod(gfc_se * se,gfc_expr * expr)3694 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3695 {
3696 tree type;
3697 tree args[2];
3698
3699 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3700
3701 /* Convert the args to double precision before multiplying. */
3702 type = gfc_typenode_for_spec (&expr->ts);
3703 args[0] = convert (type, args[0]);
3704 args[1] = convert (type, args[1]);
3705 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3706 args[1]);
3707 }
3708
3709
3710 /* Return a length one character string containing an ascii character. */
3711
3712 static void
gfc_conv_intrinsic_char(gfc_se * se,gfc_expr * expr)3713 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3714 {
3715 tree arg[2];
3716 tree var;
3717 tree type;
3718 unsigned int num_args;
3719
3720 num_args = gfc_intrinsic_argument_list_length (expr);
3721 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3722
3723 type = gfc_get_char_type (expr->ts.kind);
3724 var = gfc_create_var (type, "char");
3725
3726 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3727 gfc_add_modify (&se->pre, var, arg[0]);
3728 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3729 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3730 }
3731
3732
3733 static void
gfc_conv_intrinsic_ctime(gfc_se * se,gfc_expr * expr)3734 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3735 {
3736 tree var;
3737 tree len;
3738 tree tmp;
3739 tree cond;
3740 tree fndecl;
3741 tree *args;
3742 unsigned int num_args;
3743
3744 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3745 args = XALLOCAVEC (tree, num_args);
3746
3747 var = gfc_create_var (pchar_type_node, "pstr");
3748 len = gfc_create_var (gfc_charlen_type_node, "len");
3749
3750 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3751 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3752 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3753
3754 fndecl = build_addr (gfor_fndecl_ctime);
3755 tmp = build_call_array_loc (input_location,
3756 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3757 fndecl, num_args, args);
3758 gfc_add_expr_to_block (&se->pre, tmp);
3759
3760 /* Free the temporary afterwards, if necessary. */
3761 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3762 len, build_int_cst (TREE_TYPE (len), 0));
3763 tmp = gfc_call_free (var);
3764 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3765 gfc_add_expr_to_block (&se->post, tmp);
3766
3767 se->expr = var;
3768 se->string_length = len;
3769 }
3770
3771
3772 static void
gfc_conv_intrinsic_fdate(gfc_se * se,gfc_expr * expr)3773 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3774 {
3775 tree var;
3776 tree len;
3777 tree tmp;
3778 tree cond;
3779 tree fndecl;
3780 tree *args;
3781 unsigned int num_args;
3782
3783 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3784 args = XALLOCAVEC (tree, num_args);
3785
3786 var = gfc_create_var (pchar_type_node, "pstr");
3787 len = gfc_create_var (gfc_charlen_type_node, "len");
3788
3789 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3790 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3791 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3792
3793 fndecl = build_addr (gfor_fndecl_fdate);
3794 tmp = build_call_array_loc (input_location,
3795 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3796 fndecl, num_args, args);
3797 gfc_add_expr_to_block (&se->pre, tmp);
3798
3799 /* Free the temporary afterwards, if necessary. */
3800 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3801 len, build_int_cst (TREE_TYPE (len), 0));
3802 tmp = gfc_call_free (var);
3803 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3804 gfc_add_expr_to_block (&se->post, tmp);
3805
3806 se->expr = var;
3807 se->string_length = len;
3808 }
3809
3810
3811 /* Generate a direct call to free() for the FREE subroutine. */
3812
3813 static tree
conv_intrinsic_free(gfc_code * code)3814 conv_intrinsic_free (gfc_code *code)
3815 {
3816 stmtblock_t block;
3817 gfc_se argse;
3818 tree arg, call;
3819
3820 gfc_init_se (&argse, NULL);
3821 gfc_conv_expr (&argse, code->ext.actual->expr);
3822 arg = fold_convert (ptr_type_node, argse.expr);
3823
3824 gfc_init_block (&block);
3825 call = build_call_expr_loc (input_location,
3826 builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3827 gfc_add_expr_to_block (&block, call);
3828 return gfc_finish_block (&block);
3829 }
3830
3831
3832 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3833 handling seeding on coarray images. */
3834
3835 static tree
conv_intrinsic_random_init(gfc_code * code)3836 conv_intrinsic_random_init (gfc_code *code)
3837 {
3838 stmtblock_t block;
3839 gfc_se se;
3840 tree arg1, arg2, tmp;
3841 /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3842 tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3843 ? logical_type_node
3844 : gfc_get_logical_type (4);
3845
3846 /* Make the function call. */
3847 gfc_init_block (&block);
3848 gfc_init_se (&se, NULL);
3849
3850 /* Convert REPEATABLE to the desired LOGICAL entity. */
3851 gfc_conv_expr (&se, code->ext.actual->expr);
3852 gfc_add_block_to_block (&block, &se.pre);
3853 arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3854 gfc_add_block_to_block (&block, &se.post);
3855
3856 /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3857 gfc_conv_expr (&se, code->ext.actual->next->expr);
3858 gfc_add_block_to_block (&block, &se.pre);
3859 arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3860 gfc_add_block_to_block (&block, &se.post);
3861
3862 if (flag_coarray == GFC_FCOARRAY_LIB)
3863 {
3864 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3865 2, arg1, arg2);
3866 }
3867 else
3868 {
3869 /* The ABI for libgfortran needs to be maintained, so a hidden
3870 argument must be include if code is compiled with -fcoarray=single
3871 or without the option. Set to 0. */
3872 tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3873 tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3874 3, arg1, arg2, arg3);
3875 }
3876
3877 gfc_add_expr_to_block (&block, tmp);
3878
3879 return gfc_finish_block (&block);
3880 }
3881
3882
3883 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3884 conversions. */
3885
3886 static tree
conv_intrinsic_system_clock(gfc_code * code)3887 conv_intrinsic_system_clock (gfc_code *code)
3888 {
3889 stmtblock_t block;
3890 gfc_se count_se, count_rate_se, count_max_se;
3891 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3892 tree tmp;
3893 int least;
3894
3895 gfc_expr *count = code->ext.actual->expr;
3896 gfc_expr *count_rate = code->ext.actual->next->expr;
3897 gfc_expr *count_max = code->ext.actual->next->next->expr;
3898
3899 /* Evaluate our arguments. */
3900 if (count)
3901 {
3902 gfc_init_se (&count_se, NULL);
3903 gfc_conv_expr (&count_se, count);
3904 }
3905
3906 if (count_rate)
3907 {
3908 gfc_init_se (&count_rate_se, NULL);
3909 gfc_conv_expr (&count_rate_se, count_rate);
3910 }
3911
3912 if (count_max)
3913 {
3914 gfc_init_se (&count_max_se, NULL);
3915 gfc_conv_expr (&count_max_se, count_max);
3916 }
3917
3918 /* Find the smallest kind found of the arguments. */
3919 least = 16;
3920 least = (count && count->ts.kind < least) ? count->ts.kind : least;
3921 least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3922 : least;
3923 least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3924 : least;
3925
3926 /* Prepare temporary variables. */
3927
3928 if (count)
3929 {
3930 if (least >= 8)
3931 arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3932 else if (least == 4)
3933 arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3934 else if (count->ts.kind == 1)
3935 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3936 count->ts.kind);
3937 else
3938 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3939 count->ts.kind);
3940 }
3941
3942 if (count_rate)
3943 {
3944 if (least >= 8)
3945 arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3946 else if (least == 4)
3947 arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3948 else
3949 arg2 = integer_zero_node;
3950 }
3951
3952 if (count_max)
3953 {
3954 if (least >= 8)
3955 arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3956 else if (least == 4)
3957 arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3958 else
3959 arg3 = integer_zero_node;
3960 }
3961
3962 /* Make the function call. */
3963 gfc_init_block (&block);
3964
3965 if (least <= 2)
3966 {
3967 if (least == 1)
3968 {
3969 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3970 : null_pointer_node;
3971 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3972 : null_pointer_node;
3973 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3974 : null_pointer_node;
3975 }
3976
3977 if (least == 2)
3978 {
3979 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3980 : null_pointer_node;
3981 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3982 : null_pointer_node;
3983 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3984 : null_pointer_node;
3985 }
3986 }
3987 else
3988 {
3989 if (least == 4)
3990 {
3991 tmp = build_call_expr_loc (input_location,
3992 gfor_fndecl_system_clock4, 3,
3993 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3994 : null_pointer_node,
3995 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3996 : null_pointer_node,
3997 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3998 : null_pointer_node);
3999 gfc_add_expr_to_block (&block, tmp);
4000 }
4001 /* Handle kind>=8, 10, or 16 arguments */
4002 if (least >= 8)
4003 {
4004 tmp = build_call_expr_loc (input_location,
4005 gfor_fndecl_system_clock8, 3,
4006 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
4007 : null_pointer_node,
4008 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
4009 : null_pointer_node,
4010 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
4011 : null_pointer_node);
4012 gfc_add_expr_to_block (&block, tmp);
4013 }
4014 }
4015
4016 /* And store values back if needed. */
4017 if (arg1 && arg1 != count_se.expr)
4018 gfc_add_modify (&block, count_se.expr,
4019 fold_convert (TREE_TYPE (count_se.expr), arg1));
4020 if (arg2 && arg2 != count_rate_se.expr)
4021 gfc_add_modify (&block, count_rate_se.expr,
4022 fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
4023 if (arg3 && arg3 != count_max_se.expr)
4024 gfc_add_modify (&block, count_max_se.expr,
4025 fold_convert (TREE_TYPE (count_max_se.expr), arg3));
4026
4027 return gfc_finish_block (&block);
4028 }
4029
4030
4031 /* Return a character string containing the tty name. */
4032
4033 static void
gfc_conv_intrinsic_ttynam(gfc_se * se,gfc_expr * expr)4034 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
4035 {
4036 tree var;
4037 tree len;
4038 tree tmp;
4039 tree cond;
4040 tree fndecl;
4041 tree *args;
4042 unsigned int num_args;
4043
4044 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4045 args = XALLOCAVEC (tree, num_args);
4046
4047 var = gfc_create_var (pchar_type_node, "pstr");
4048 len = gfc_create_var (gfc_charlen_type_node, "len");
4049
4050 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4051 args[0] = gfc_build_addr_expr (NULL_TREE, var);
4052 args[1] = gfc_build_addr_expr (NULL_TREE, len);
4053
4054 fndecl = build_addr (gfor_fndecl_ttynam);
4055 tmp = build_call_array_loc (input_location,
4056 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
4057 fndecl, num_args, args);
4058 gfc_add_expr_to_block (&se->pre, tmp);
4059
4060 /* Free the temporary afterwards, if necessary. */
4061 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4062 len, build_int_cst (TREE_TYPE (len), 0));
4063 tmp = gfc_call_free (var);
4064 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4065 gfc_add_expr_to_block (&se->post, tmp);
4066
4067 se->expr = var;
4068 se->string_length = len;
4069 }
4070
4071
4072 /* Get the minimum/maximum value of all the parameters.
4073 minmax (a1, a2, a3, ...)
4074 {
4075 mvar = a1;
4076 mvar = COMP (mvar, a2)
4077 mvar = COMP (mvar, a3)
4078 ...
4079 return mvar;
4080 }
4081 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4082 care about NaNs, or IFN_FMIN/MAX when the target has support for
4083 fast NaN-honouring min/max. When neither holds expand a sequence
4084 of explicit comparisons. */
4085
4086 /* TODO: Mismatching types can occur when specific names are used.
4087 These should be handled during resolution. */
4088 static void
gfc_conv_intrinsic_minmax(gfc_se * se,gfc_expr * expr,enum tree_code op)4089 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
4090 {
4091 tree tmp;
4092 tree mvar;
4093 tree val;
4094 tree *args;
4095 tree type;
4096 tree argtype;
4097 gfc_actual_arglist *argexpr;
4098 unsigned int i, nargs;
4099
4100 nargs = gfc_intrinsic_argument_list_length (expr);
4101 args = XALLOCAVEC (tree, nargs);
4102
4103 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
4104 type = gfc_typenode_for_spec (&expr->ts);
4105
4106 /* Only evaluate the argument once. */
4107 if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
4108 args[0] = gfc_evaluate_now (args[0], &se->pre);
4109
4110 /* Determine suitable type of temporary, as a GNU extension allows
4111 different argument kinds. */
4112 argtype = TREE_TYPE (args[0]);
4113 argexpr = expr->value.function.actual;
4114 for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4115 {
4116 tree tmptype = TREE_TYPE (args[i]);
4117 if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
4118 argtype = tmptype;
4119 }
4120 mvar = gfc_create_var (argtype, "M");
4121 gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
4122
4123 argexpr = expr->value.function.actual;
4124 for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4125 {
4126 tree cond = NULL_TREE;
4127 val = args[i];
4128
4129 /* Handle absent optional arguments by ignoring the comparison. */
4130 if (argexpr->expr->expr_type == EXPR_VARIABLE
4131 && argexpr->expr->symtree->n.sym->attr.optional
4132 && TREE_CODE (val) == INDIRECT_REF)
4133 {
4134 cond = fold_build2_loc (input_location,
4135 NE_EXPR, logical_type_node,
4136 TREE_OPERAND (val, 0),
4137 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
4138 }
4139 else if (!VAR_P (val) && !TREE_CONSTANT (val))
4140 /* Only evaluate the argument once. */
4141 val = gfc_evaluate_now (val, &se->pre);
4142
4143 tree calc;
4144 /* For floating point types, the question is what MAX(a, NaN) or
4145 MIN(a, NaN) should return (where "a" is a normal number).
4146 There are valid usecase for returning either one, but the
4147 Fortran standard doesn't specify which one should be chosen.
4148 Also, there is no consensus among other tested compilers. In
4149 short, it's a mess. So lets just do whatever is fastest. */
4150 tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
4151 calc = fold_build2_loc (input_location, code, argtype,
4152 convert (argtype, val), mvar);
4153 tmp = build2_v (MODIFY_EXPR, mvar, calc);
4154
4155 if (cond != NULL_TREE)
4156 tmp = build3_v (COND_EXPR, cond, tmp,
4157 build_empty_stmt (input_location));
4158 gfc_add_expr_to_block (&se->pre, tmp);
4159 }
4160 se->expr = convert (type, mvar);
4161 }
4162
4163
4164 /* Generate library calls for MIN and MAX intrinsics for character
4165 variables. */
4166 static void
gfc_conv_intrinsic_minmax_char(gfc_se * se,gfc_expr * expr,int op)4167 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
4168 {
4169 tree *args;
4170 tree var, len, fndecl, tmp, cond, function;
4171 unsigned int nargs;
4172
4173 nargs = gfc_intrinsic_argument_list_length (expr);
4174 args = XALLOCAVEC (tree, nargs + 4);
4175 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
4176
4177 /* Create the result variables. */
4178 len = gfc_create_var (gfc_charlen_type_node, "len");
4179 args[0] = gfc_build_addr_expr (NULL_TREE, len);
4180 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4181 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
4182 args[2] = build_int_cst (integer_type_node, op);
4183 args[3] = build_int_cst (integer_type_node, nargs / 2);
4184
4185 if (expr->ts.kind == 1)
4186 function = gfor_fndecl_string_minmax;
4187 else if (expr->ts.kind == 4)
4188 function = gfor_fndecl_string_minmax_char4;
4189 else
4190 gcc_unreachable ();
4191
4192 /* Make the function call. */
4193 fndecl = build_addr (function);
4194 tmp = build_call_array_loc (input_location,
4195 TREE_TYPE (TREE_TYPE (function)), fndecl,
4196 nargs + 4, args);
4197 gfc_add_expr_to_block (&se->pre, tmp);
4198
4199 /* Free the temporary afterwards, if necessary. */
4200 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4201 len, build_int_cst (TREE_TYPE (len), 0));
4202 tmp = gfc_call_free (var);
4203 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4204 gfc_add_expr_to_block (&se->post, tmp);
4205
4206 se->expr = var;
4207 se->string_length = len;
4208 }
4209
4210
4211 /* Create a symbol node for this intrinsic. The symbol from the frontend
4212 has the generic name. */
4213
4214 static gfc_symbol *
gfc_get_symbol_for_expr(gfc_expr * expr,bool ignore_optional)4215 gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
4216 {
4217 gfc_symbol *sym;
4218
4219 /* TODO: Add symbols for intrinsic function to the global namespace. */
4220 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
4221 sym = gfc_new_symbol (expr->value.function.name, NULL);
4222
4223 sym->ts = expr->ts;
4224 sym->attr.external = 1;
4225 sym->attr.function = 1;
4226 sym->attr.always_explicit = 1;
4227 sym->attr.proc = PROC_INTRINSIC;
4228 sym->attr.flavor = FL_PROCEDURE;
4229 sym->result = sym;
4230 if (expr->rank > 0)
4231 {
4232 sym->attr.dimension = 1;
4233 sym->as = gfc_get_array_spec ();
4234 sym->as->type = AS_ASSUMED_SHAPE;
4235 sym->as->rank = expr->rank;
4236 }
4237
4238 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4239 ignore_optional ? expr->value.function.actual
4240 : NULL);
4241
4242 return sym;
4243 }
4244
4245 /* Remove empty actual arguments. */
4246
4247 static void
remove_empty_actual_arguments(gfc_actual_arglist ** ap)4248 remove_empty_actual_arguments (gfc_actual_arglist **ap)
4249 {
4250 while (*ap)
4251 {
4252 if ((*ap)->expr == NULL)
4253 {
4254 gfc_actual_arglist *r = *ap;
4255 *ap = r->next;
4256 r->next = NULL;
4257 gfc_free_actual_arglist (r);
4258 }
4259 else
4260 ap = &((*ap)->next);
4261 }
4262 }
4263
4264 #define MAX_SPEC_ARG 12
4265
4266 /* Make up an fn spec that's right for intrinsic functions that we
4267 want to call. */
4268
4269 static char *
intrinsic_fnspec(gfc_expr * expr)4270 intrinsic_fnspec (gfc_expr *expr)
4271 {
4272 static char fnspec_buf[MAX_SPEC_ARG*2+1];
4273 char *fp;
4274 int i;
4275 int num_char_args;
4276
4277 #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
4278
4279 /* Set the fndecl. */
4280 fp = fnspec_buf;
4281 /* Function return value. FIXME: Check if the second letter could
4282 be something other than a space, for further optimization. */
4283 ADD_CHAR ('.');
4284 if (expr->rank == 0)
4285 {
4286 if (expr->ts.type == BT_CHARACTER)
4287 {
4288 ADD_CHAR ('w'); /* Address of character. */
4289 ADD_CHAR ('.'); /* Length of character. */
4290 }
4291 }
4292 else
4293 ADD_CHAR ('w'); /* Return value is a descriptor. */
4294
4295 num_char_args = 0;
4296 for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
4297 {
4298 if (a->expr == NULL)
4299 continue;
4300
4301 if (a->name && strcmp (a->name,"%VAL") == 0)
4302 ADD_CHAR ('.');
4303 else
4304 {
4305 if (a->expr->rank > 0)
4306 ADD_CHAR ('r');
4307 else
4308 ADD_CHAR ('R');
4309 }
4310 num_char_args += a->expr->ts.type == BT_CHARACTER;
4311 gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
4312 }
4313
4314 for (i = 0; i < num_char_args; i++)
4315 ADD_CHAR ('.');
4316
4317 *fp = '\0';
4318 return fnspec_buf;
4319 }
4320
4321 #undef MAX_SPEC_ARG
4322 #undef ADD_CHAR
4323
4324 /* Generate the right symbol for the specific intrinsic function and
4325 modify the expr accordingly. This assumes that absent optional
4326 arguments should be removed. */
4327
4328 gfc_symbol *
specific_intrinsic_symbol(gfc_expr * expr)4329 specific_intrinsic_symbol (gfc_expr *expr)
4330 {
4331 gfc_symbol *sym;
4332
4333 sym = gfc_find_intrinsic_symbol (expr);
4334 if (sym == NULL)
4335 {
4336 sym = gfc_get_intrinsic_function_symbol (expr);
4337 sym->ts = expr->ts;
4338 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
4339 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
4340
4341 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4342 expr->value.function.actual, true);
4343 sym->backend_decl
4344 = gfc_get_extern_function_decl (sym, expr->value.function.actual,
4345 intrinsic_fnspec (expr));
4346 }
4347
4348 remove_empty_actual_arguments (&(expr->value.function.actual));
4349
4350 return sym;
4351 }
4352
4353 /* Generate a call to an external intrinsic function. FIXME: So far,
4354 this only works for functions which are called with well-defined
4355 types; CSHIFT and friends will come later. */
4356
4357 static void
gfc_conv_intrinsic_funcall(gfc_se * se,gfc_expr * expr)4358 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
4359 {
4360 gfc_symbol *sym;
4361 vec<tree, va_gc> *append_args;
4362 bool specific_symbol;
4363
4364 gcc_assert (!se->ss || se->ss->info->expr == expr);
4365
4366 if (se->ss)
4367 gcc_assert (expr->rank > 0);
4368 else
4369 gcc_assert (expr->rank == 0);
4370
4371 switch (expr->value.function.isym->id)
4372 {
4373 case GFC_ISYM_ANY:
4374 case GFC_ISYM_ALL:
4375 case GFC_ISYM_FINDLOC:
4376 case GFC_ISYM_MAXLOC:
4377 case GFC_ISYM_MINLOC:
4378 case GFC_ISYM_MAXVAL:
4379 case GFC_ISYM_MINVAL:
4380 case GFC_ISYM_NORM2:
4381 case GFC_ISYM_PRODUCT:
4382 case GFC_ISYM_SUM:
4383 specific_symbol = true;
4384 break;
4385 default:
4386 specific_symbol = false;
4387 }
4388
4389 if (specific_symbol)
4390 {
4391 /* Need to copy here because specific_intrinsic_symbol modifies
4392 expr to omit the absent optional arguments. */
4393 expr = gfc_copy_expr (expr);
4394 sym = specific_intrinsic_symbol (expr);
4395 }
4396 else
4397 sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
4398
4399 /* Calls to libgfortran_matmul need to be appended special arguments,
4400 to be able to call the BLAS ?gemm functions if required and possible. */
4401 append_args = NULL;
4402 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
4403 && !expr->external_blas
4404 && sym->ts.type != BT_LOGICAL)
4405 {
4406 tree cint = gfc_get_int_type (gfc_c_int_kind);
4407
4408 if (flag_external_blas
4409 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
4410 && (sym->ts.kind == 4 || sym->ts.kind == 8))
4411 {
4412 tree gemm_fndecl;
4413
4414 if (sym->ts.type == BT_REAL)
4415 {
4416 if (sym->ts.kind == 4)
4417 gemm_fndecl = gfor_fndecl_sgemm;
4418 else
4419 gemm_fndecl = gfor_fndecl_dgemm;
4420 }
4421 else
4422 {
4423 if (sym->ts.kind == 4)
4424 gemm_fndecl = gfor_fndecl_cgemm;
4425 else
4426 gemm_fndecl = gfor_fndecl_zgemm;
4427 }
4428
4429 vec_alloc (append_args, 3);
4430 append_args->quick_push (build_int_cst (cint, 1));
4431 append_args->quick_push (build_int_cst (cint,
4432 flag_blas_matmul_limit));
4433 append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
4434 gemm_fndecl));
4435 }
4436 else
4437 {
4438 vec_alloc (append_args, 3);
4439 append_args->quick_push (build_int_cst (cint, 0));
4440 append_args->quick_push (build_int_cst (cint, 0));
4441 append_args->quick_push (null_pointer_node);
4442 }
4443 }
4444
4445 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4446 append_args);
4447
4448 if (specific_symbol)
4449 gfc_free_expr (expr);
4450 else
4451 gfc_free_symbol (sym);
4452 }
4453
4454 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4455 Implemented as
4456 any(a)
4457 {
4458 forall (i=...)
4459 if (a[i] != 0)
4460 return 1
4461 end forall
4462 return 0
4463 }
4464 all(a)
4465 {
4466 forall (i=...)
4467 if (a[i] == 0)
4468 return 0
4469 end forall
4470 return 1
4471 }
4472 */
4473 static void
gfc_conv_intrinsic_anyall(gfc_se * se,gfc_expr * expr,enum tree_code op)4474 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4475 {
4476 tree resvar;
4477 stmtblock_t block;
4478 stmtblock_t body;
4479 tree type;
4480 tree tmp;
4481 tree found;
4482 gfc_loopinfo loop;
4483 gfc_actual_arglist *actual;
4484 gfc_ss *arrayss;
4485 gfc_se arrayse;
4486 tree exit_label;
4487
4488 if (se->ss)
4489 {
4490 gfc_conv_intrinsic_funcall (se, expr);
4491 return;
4492 }
4493
4494 actual = expr->value.function.actual;
4495 type = gfc_typenode_for_spec (&expr->ts);
4496 /* Initialize the result. */
4497 resvar = gfc_create_var (type, "test");
4498 if (op == EQ_EXPR)
4499 tmp = convert (type, boolean_true_node);
4500 else
4501 tmp = convert (type, boolean_false_node);
4502 gfc_add_modify (&se->pre, resvar, tmp);
4503
4504 /* Walk the arguments. */
4505 arrayss = gfc_walk_expr (actual->expr);
4506 gcc_assert (arrayss != gfc_ss_terminator);
4507
4508 /* Initialize the scalarizer. */
4509 gfc_init_loopinfo (&loop);
4510 exit_label = gfc_build_label_decl (NULL_TREE);
4511 TREE_USED (exit_label) = 1;
4512 gfc_add_ss_to_loop (&loop, arrayss);
4513
4514 /* Initialize the loop. */
4515 gfc_conv_ss_startstride (&loop);
4516 gfc_conv_loop_setup (&loop, &expr->where);
4517
4518 gfc_mark_ss_chain_used (arrayss, 1);
4519 /* Generate the loop body. */
4520 gfc_start_scalarized_body (&loop, &body);
4521
4522 /* If the condition matches then set the return value. */
4523 gfc_start_block (&block);
4524 if (op == EQ_EXPR)
4525 tmp = convert (type, boolean_false_node);
4526 else
4527 tmp = convert (type, boolean_true_node);
4528 gfc_add_modify (&block, resvar, tmp);
4529
4530 /* And break out of the loop. */
4531 tmp = build1_v (GOTO_EXPR, exit_label);
4532 gfc_add_expr_to_block (&block, tmp);
4533
4534 found = gfc_finish_block (&block);
4535
4536 /* Check this element. */
4537 gfc_init_se (&arrayse, NULL);
4538 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4539 arrayse.ss = arrayss;
4540 gfc_conv_expr_val (&arrayse, actual->expr);
4541
4542 gfc_add_block_to_block (&body, &arrayse.pre);
4543 tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4544 build_int_cst (TREE_TYPE (arrayse.expr), 0));
4545 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4546 gfc_add_expr_to_block (&body, tmp);
4547 gfc_add_block_to_block (&body, &arrayse.post);
4548
4549 gfc_trans_scalarizing_loops (&loop, &body);
4550
4551 /* Add the exit label. */
4552 tmp = build1_v (LABEL_EXPR, exit_label);
4553 gfc_add_expr_to_block (&loop.pre, tmp);
4554
4555 gfc_add_block_to_block (&se->pre, &loop.pre);
4556 gfc_add_block_to_block (&se->pre, &loop.post);
4557 gfc_cleanup_loop (&loop);
4558
4559 se->expr = resvar;
4560 }
4561
4562
4563 /* Generate the constant 180 / pi, which is used in the conversion
4564 of acosd(), asind(), atand(), atan2d(). */
4565
4566 static tree
rad2deg(int kind)4567 rad2deg (int kind)
4568 {
4569 tree retval;
4570 mpfr_t pi, t0;
4571
4572 gfc_set_model_kind (kind);
4573 mpfr_init (pi);
4574 mpfr_init (t0);
4575 mpfr_set_si (t0, 180, GFC_RND_MODE);
4576 mpfr_const_pi (pi, GFC_RND_MODE);
4577 mpfr_div (t0, t0, pi, GFC_RND_MODE);
4578 retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4579 mpfr_clear (t0);
4580 mpfr_clear (pi);
4581 return retval;
4582 }
4583
4584
4585 /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4586 ASIND(x) is translated into ASIN(x) * 180 / pi.
4587 ATAND(x) is translated into ATAN(x) * 180 / pi. */
4588
4589 static void
gfc_conv_intrinsic_atrigd(gfc_se * se,gfc_expr * expr,gfc_isym_id id)4590 gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4591 {
4592 tree arg;
4593 tree atrigd;
4594 tree type;
4595
4596 type = gfc_typenode_for_spec (&expr->ts);
4597
4598 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4599
4600 if (id == GFC_ISYM_ACOSD)
4601 atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ACOS, expr->ts.kind);
4602 else if (id == GFC_ISYM_ASIND)
4603 atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ASIN, expr->ts.kind);
4604 else if (id == GFC_ISYM_ATAND)
4605 atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN, expr->ts.kind);
4606 else
4607 gcc_unreachable ();
4608
4609 atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4610
4611 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4612 fold_convert (type, rad2deg (expr->ts.kind)));
4613 }
4614
4615
4616 /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4617 COS(X) / SIN(X) for COMPLEX argument. */
4618
4619 static void
gfc_conv_intrinsic_cotan(gfc_se * se,gfc_expr * expr)4620 gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4621 {
4622 gfc_intrinsic_map_t *m;
4623 tree arg;
4624 tree type;
4625
4626 type = gfc_typenode_for_spec (&expr->ts);
4627 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4628
4629 if (expr->ts.type == BT_REAL)
4630 {
4631 tree tan;
4632 tree tmp;
4633 mpfr_t pio2;
4634
4635 /* Create pi/2. */
4636 gfc_set_model_kind (expr->ts.kind);
4637 mpfr_init (pio2);
4638 mpfr_const_pi (pio2, GFC_RND_MODE);
4639 mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4640 tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4641 mpfr_clear (pio2);
4642
4643 /* Find tan builtin function. */
4644 m = gfc_intrinsic_map;
4645 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4646 if (GFC_ISYM_TAN == m->id)
4647 break;
4648
4649 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4650 tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4651 tan = build_call_expr_loc (input_location, tan, 1, tmp);
4652 se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4653 }
4654 else
4655 {
4656 tree sin;
4657 tree cos;
4658
4659 /* Find cos builtin function. */
4660 m = gfc_intrinsic_map;
4661 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4662 if (GFC_ISYM_COS == m->id)
4663 break;
4664
4665 cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4666 cos = build_call_expr_loc (input_location, cos, 1, arg);
4667
4668 /* Find sin builtin function. */
4669 m = gfc_intrinsic_map;
4670 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4671 if (GFC_ISYM_SIN == m->id)
4672 break;
4673
4674 sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4675 sin = build_call_expr_loc (input_location, sin, 1, arg);
4676
4677 /* Divide cos by sin. */
4678 se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4679 }
4680 }
4681
4682
4683 /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4684
4685 static void
gfc_conv_intrinsic_cotand(gfc_se * se,gfc_expr * expr)4686 gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4687 {
4688 tree arg;
4689 tree type;
4690 tree ninety_tree;
4691 mpfr_t ninety;
4692
4693 type = gfc_typenode_for_spec (&expr->ts);
4694 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4695
4696 gfc_set_model_kind (expr->ts.kind);
4697
4698 /* Build the tree for x + 90. */
4699 mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4700 ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4701 arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4702 mpfr_clear (ninety);
4703
4704 /* Find tand. */
4705 gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4706 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4707 if (GFC_ISYM_TAND == m->id)
4708 break;
4709
4710 tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4711 tand = build_call_expr_loc (input_location, tand, 1, arg);
4712
4713 se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4714 }
4715
4716
4717 /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4718
4719 static void
gfc_conv_intrinsic_atan2d(gfc_se * se,gfc_expr * expr)4720 gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4721 {
4722 tree args[2];
4723 tree atan2d;
4724 tree type;
4725
4726 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4727 type = TREE_TYPE (args[0]);
4728
4729 atan2d = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN2, expr->ts.kind);
4730 atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4731
4732 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4733 rad2deg (expr->ts.kind));
4734 }
4735
4736
4737 /* COUNT(A) = Number of true elements in A. */
4738 static void
gfc_conv_intrinsic_count(gfc_se * se,gfc_expr * expr)4739 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4740 {
4741 tree resvar;
4742 tree type;
4743 stmtblock_t body;
4744 tree tmp;
4745 gfc_loopinfo loop;
4746 gfc_actual_arglist *actual;
4747 gfc_ss *arrayss;
4748 gfc_se arrayse;
4749
4750 if (se->ss)
4751 {
4752 gfc_conv_intrinsic_funcall (se, expr);
4753 return;
4754 }
4755
4756 actual = expr->value.function.actual;
4757
4758 type = gfc_typenode_for_spec (&expr->ts);
4759 /* Initialize the result. */
4760 resvar = gfc_create_var (type, "count");
4761 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4762
4763 /* Walk the arguments. */
4764 arrayss = gfc_walk_expr (actual->expr);
4765 gcc_assert (arrayss != gfc_ss_terminator);
4766
4767 /* Initialize the scalarizer. */
4768 gfc_init_loopinfo (&loop);
4769 gfc_add_ss_to_loop (&loop, arrayss);
4770
4771 /* Initialize the loop. */
4772 gfc_conv_ss_startstride (&loop);
4773 gfc_conv_loop_setup (&loop, &expr->where);
4774
4775 gfc_mark_ss_chain_used (arrayss, 1);
4776 /* Generate the loop body. */
4777 gfc_start_scalarized_body (&loop, &body);
4778
4779 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4780 resvar, build_int_cst (TREE_TYPE (resvar), 1));
4781 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4782
4783 gfc_init_se (&arrayse, NULL);
4784 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4785 arrayse.ss = arrayss;
4786 gfc_conv_expr_val (&arrayse, actual->expr);
4787 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4788 build_empty_stmt (input_location));
4789
4790 gfc_add_block_to_block (&body, &arrayse.pre);
4791 gfc_add_expr_to_block (&body, tmp);
4792 gfc_add_block_to_block (&body, &arrayse.post);
4793
4794 gfc_trans_scalarizing_loops (&loop, &body);
4795
4796 gfc_add_block_to_block (&se->pre, &loop.pre);
4797 gfc_add_block_to_block (&se->pre, &loop.post);
4798 gfc_cleanup_loop (&loop);
4799
4800 se->expr = resvar;
4801 }
4802
4803
4804 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4805 struct and return the corresponding loopinfo. */
4806
4807 static gfc_loopinfo *
enter_nested_loop(gfc_se * se)4808 enter_nested_loop (gfc_se *se)
4809 {
4810 se->ss = se->ss->nested_ss;
4811 gcc_assert (se->ss == se->ss->loop->ss);
4812
4813 return se->ss->loop;
4814 }
4815
4816 /* Build the condition for a mask, which may be optional. */
4817
4818 static tree
conv_mask_condition(gfc_se * maskse,gfc_expr * maskexpr,bool optional_mask)4819 conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4820 bool optional_mask)
4821 {
4822 tree present;
4823 tree type;
4824
4825 if (optional_mask)
4826 {
4827 type = TREE_TYPE (maskse->expr);
4828 present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4829 present = convert (type, present);
4830 present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4831 present);
4832 return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4833 type, present, maskse->expr);
4834 }
4835 else
4836 return maskse->expr;
4837 }
4838
4839 /* Inline implementation of the sum and product intrinsics. */
4840 static void
gfc_conv_intrinsic_arith(gfc_se * se,gfc_expr * expr,enum tree_code op,bool norm2)4841 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4842 bool norm2)
4843 {
4844 tree resvar;
4845 tree scale = NULL_TREE;
4846 tree type;
4847 stmtblock_t body;
4848 stmtblock_t block;
4849 tree tmp;
4850 gfc_loopinfo loop, *ploop;
4851 gfc_actual_arglist *arg_array, *arg_mask;
4852 gfc_ss *arrayss = NULL;
4853 gfc_ss *maskss = NULL;
4854 gfc_se arrayse;
4855 gfc_se maskse;
4856 gfc_se *parent_se;
4857 gfc_expr *arrayexpr;
4858 gfc_expr *maskexpr;
4859 bool optional_mask;
4860
4861 if (expr->rank > 0)
4862 {
4863 gcc_assert (gfc_inline_intrinsic_function_p (expr));
4864 parent_se = se;
4865 }
4866 else
4867 parent_se = NULL;
4868
4869 type = gfc_typenode_for_spec (&expr->ts);
4870 /* Initialize the result. */
4871 resvar = gfc_create_var (type, "val");
4872 if (norm2)
4873 {
4874 /* result = 0.0;
4875 scale = 1.0. */
4876 scale = gfc_create_var (type, "scale");
4877 gfc_add_modify (&se->pre, scale,
4878 gfc_build_const (type, integer_one_node));
4879 tmp = gfc_build_const (type, integer_zero_node);
4880 }
4881 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4882 tmp = gfc_build_const (type, integer_zero_node);
4883 else if (op == NE_EXPR)
4884 /* PARITY. */
4885 tmp = convert (type, boolean_false_node);
4886 else if (op == BIT_AND_EXPR)
4887 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4888 type, integer_one_node));
4889 else
4890 tmp = gfc_build_const (type, integer_one_node);
4891
4892 gfc_add_modify (&se->pre, resvar, tmp);
4893
4894 arg_array = expr->value.function.actual;
4895
4896 arrayexpr = arg_array->expr;
4897
4898 if (op == NE_EXPR || norm2)
4899 {
4900 /* PARITY and NORM2. */
4901 maskexpr = NULL;
4902 optional_mask = false;
4903 }
4904 else
4905 {
4906 arg_mask = arg_array->next->next;
4907 gcc_assert (arg_mask != NULL);
4908 maskexpr = arg_mask->expr;
4909 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4910 && maskexpr->symtree->n.sym->attr.dummy
4911 && maskexpr->symtree->n.sym->attr.optional;
4912 }
4913
4914 if (expr->rank == 0)
4915 {
4916 /* Walk the arguments. */
4917 arrayss = gfc_walk_expr (arrayexpr);
4918 gcc_assert (arrayss != gfc_ss_terminator);
4919
4920 if (maskexpr && maskexpr->rank > 0)
4921 {
4922 maskss = gfc_walk_expr (maskexpr);
4923 gcc_assert (maskss != gfc_ss_terminator);
4924 }
4925 else
4926 maskss = NULL;
4927
4928 /* Initialize the scalarizer. */
4929 gfc_init_loopinfo (&loop);
4930
4931 /* We add the mask first because the number of iterations is
4932 taken from the last ss, and this breaks if an absent
4933 optional argument is used for mask. */
4934
4935 if (maskexpr && maskexpr->rank > 0)
4936 gfc_add_ss_to_loop (&loop, maskss);
4937 gfc_add_ss_to_loop (&loop, arrayss);
4938
4939 /* Initialize the loop. */
4940 gfc_conv_ss_startstride (&loop);
4941 gfc_conv_loop_setup (&loop, &expr->where);
4942
4943 if (maskexpr && maskexpr->rank > 0)
4944 gfc_mark_ss_chain_used (maskss, 1);
4945 gfc_mark_ss_chain_used (arrayss, 1);
4946
4947 ploop = &loop;
4948 }
4949 else
4950 /* All the work has been done in the parent loops. */
4951 ploop = enter_nested_loop (se);
4952
4953 gcc_assert (ploop);
4954
4955 /* Generate the loop body. */
4956 gfc_start_scalarized_body (ploop, &body);
4957
4958 /* If we have a mask, only add this element if the mask is set. */
4959 if (maskexpr && maskexpr->rank > 0)
4960 {
4961 gfc_init_se (&maskse, parent_se);
4962 gfc_copy_loopinfo_to_se (&maskse, ploop);
4963 if (expr->rank == 0)
4964 maskse.ss = maskss;
4965 gfc_conv_expr_val (&maskse, maskexpr);
4966 gfc_add_block_to_block (&body, &maskse.pre);
4967
4968 gfc_start_block (&block);
4969 }
4970 else
4971 gfc_init_block (&block);
4972
4973 /* Do the actual summation/product. */
4974 gfc_init_se (&arrayse, parent_se);
4975 gfc_copy_loopinfo_to_se (&arrayse, ploop);
4976 if (expr->rank == 0)
4977 arrayse.ss = arrayss;
4978 gfc_conv_expr_val (&arrayse, arrayexpr);
4979 gfc_add_block_to_block (&block, &arrayse.pre);
4980
4981 if (norm2)
4982 {
4983 /* if (x (i) != 0.0)
4984 {
4985 absX = abs(x(i))
4986 if (absX > scale)
4987 {
4988 val = scale/absX;
4989 result = 1.0 + result * val * val;
4990 scale = absX;
4991 }
4992 else
4993 {
4994 val = absX/scale;
4995 result += val * val;
4996 }
4997 } */
4998 tree res1, res2, cond, absX, val;
4999 stmtblock_t ifblock1, ifblock2, ifblock3;
5000
5001 gfc_init_block (&ifblock1);
5002
5003 absX = gfc_create_var (type, "absX");
5004 gfc_add_modify (&ifblock1, absX,
5005 fold_build1_loc (input_location, ABS_EXPR, type,
5006 arrayse.expr));
5007 val = gfc_create_var (type, "val");
5008 gfc_add_expr_to_block (&ifblock1, val);
5009
5010 gfc_init_block (&ifblock2);
5011 gfc_add_modify (&ifblock2, val,
5012 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
5013 absX));
5014 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5015 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
5016 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
5017 gfc_build_const (type, integer_one_node));
5018 gfc_add_modify (&ifblock2, resvar, res1);
5019 gfc_add_modify (&ifblock2, scale, absX);
5020 res1 = gfc_finish_block (&ifblock2);
5021
5022 gfc_init_block (&ifblock3);
5023 gfc_add_modify (&ifblock3, val,
5024 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
5025 scale));
5026 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5027 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
5028 gfc_add_modify (&ifblock3, resvar, res2);
5029 res2 = gfc_finish_block (&ifblock3);
5030
5031 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5032 absX, scale);
5033 tmp = build3_v (COND_EXPR, cond, res1, res2);
5034 gfc_add_expr_to_block (&ifblock1, tmp);
5035 tmp = gfc_finish_block (&ifblock1);
5036
5037 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
5038 arrayse.expr,
5039 gfc_build_const (type, integer_zero_node));
5040
5041 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5042 gfc_add_expr_to_block (&block, tmp);
5043 }
5044 else
5045 {
5046 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
5047 gfc_add_modify (&block, resvar, tmp);
5048 }
5049
5050 gfc_add_block_to_block (&block, &arrayse.post);
5051
5052 if (maskexpr && maskexpr->rank > 0)
5053 {
5054 /* We enclose the above in if (mask) {...} . If the mask is an
5055 optional argument, generate
5056 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
5057 tree ifmask;
5058 tmp = gfc_finish_block (&block);
5059 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5060 tmp = build3_v (COND_EXPR, ifmask, tmp,
5061 build_empty_stmt (input_location));
5062 }
5063 else
5064 tmp = gfc_finish_block (&block);
5065 gfc_add_expr_to_block (&body, tmp);
5066
5067 gfc_trans_scalarizing_loops (ploop, &body);
5068
5069 /* For a scalar mask, enclose the loop in an if statement. */
5070 if (maskexpr && maskexpr->rank == 0)
5071 {
5072 gfc_init_block (&block);
5073 gfc_add_block_to_block (&block, &ploop->pre);
5074 gfc_add_block_to_block (&block, &ploop->post);
5075 tmp = gfc_finish_block (&block);
5076
5077 if (expr->rank > 0)
5078 {
5079 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
5080 build_empty_stmt (input_location));
5081 gfc_advance_se_ss_chain (se);
5082 }
5083 else
5084 {
5085 tree ifmask;
5086
5087 gcc_assert (expr->rank == 0);
5088 gfc_init_se (&maskse, NULL);
5089 gfc_conv_expr_val (&maskse, maskexpr);
5090 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5091 tmp = build3_v (COND_EXPR, ifmask, tmp,
5092 build_empty_stmt (input_location));
5093 }
5094
5095 gfc_add_expr_to_block (&block, tmp);
5096 gfc_add_block_to_block (&se->pre, &block);
5097 gcc_assert (se->post.head == NULL);
5098 }
5099 else
5100 {
5101 gfc_add_block_to_block (&se->pre, &ploop->pre);
5102 gfc_add_block_to_block (&se->pre, &ploop->post);
5103 }
5104
5105 if (expr->rank == 0)
5106 gfc_cleanup_loop (ploop);
5107
5108 if (norm2)
5109 {
5110 /* result = scale * sqrt(result). */
5111 tree sqrt;
5112 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
5113 resvar = build_call_expr_loc (input_location,
5114 sqrt, 1, resvar);
5115 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
5116 }
5117
5118 se->expr = resvar;
5119 }
5120
5121
5122 /* Inline implementation of the dot_product intrinsic. This function
5123 is based on gfc_conv_intrinsic_arith (the previous function). */
5124 static void
gfc_conv_intrinsic_dot_product(gfc_se * se,gfc_expr * expr)5125 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
5126 {
5127 tree resvar;
5128 tree type;
5129 stmtblock_t body;
5130 stmtblock_t block;
5131 tree tmp;
5132 gfc_loopinfo loop;
5133 gfc_actual_arglist *actual;
5134 gfc_ss *arrayss1, *arrayss2;
5135 gfc_se arrayse1, arrayse2;
5136 gfc_expr *arrayexpr1, *arrayexpr2;
5137
5138 type = gfc_typenode_for_spec (&expr->ts);
5139
5140 /* Initialize the result. */
5141 resvar = gfc_create_var (type, "val");
5142 if (expr->ts.type == BT_LOGICAL)
5143 tmp = build_int_cst (type, 0);
5144 else
5145 tmp = gfc_build_const (type, integer_zero_node);
5146
5147 gfc_add_modify (&se->pre, resvar, tmp);
5148
5149 /* Walk argument #1. */
5150 actual = expr->value.function.actual;
5151 arrayexpr1 = actual->expr;
5152 arrayss1 = gfc_walk_expr (arrayexpr1);
5153 gcc_assert (arrayss1 != gfc_ss_terminator);
5154
5155 /* Walk argument #2. */
5156 actual = actual->next;
5157 arrayexpr2 = actual->expr;
5158 arrayss2 = gfc_walk_expr (arrayexpr2);
5159 gcc_assert (arrayss2 != gfc_ss_terminator);
5160
5161 /* Initialize the scalarizer. */
5162 gfc_init_loopinfo (&loop);
5163 gfc_add_ss_to_loop (&loop, arrayss1);
5164 gfc_add_ss_to_loop (&loop, arrayss2);
5165
5166 /* Initialize the loop. */
5167 gfc_conv_ss_startstride (&loop);
5168 gfc_conv_loop_setup (&loop, &expr->where);
5169
5170 gfc_mark_ss_chain_used (arrayss1, 1);
5171 gfc_mark_ss_chain_used (arrayss2, 1);
5172
5173 /* Generate the loop body. */
5174 gfc_start_scalarized_body (&loop, &body);
5175 gfc_init_block (&block);
5176
5177 /* Make the tree expression for [conjg(]array1[)]. */
5178 gfc_init_se (&arrayse1, NULL);
5179 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
5180 arrayse1.ss = arrayss1;
5181 gfc_conv_expr_val (&arrayse1, arrayexpr1);
5182 if (expr->ts.type == BT_COMPLEX)
5183 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
5184 arrayse1.expr);
5185 gfc_add_block_to_block (&block, &arrayse1.pre);
5186
5187 /* Make the tree expression for array2. */
5188 gfc_init_se (&arrayse2, NULL);
5189 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
5190 arrayse2.ss = arrayss2;
5191 gfc_conv_expr_val (&arrayse2, arrayexpr2);
5192 gfc_add_block_to_block (&block, &arrayse2.pre);
5193
5194 /* Do the actual product and sum. */
5195 if (expr->ts.type == BT_LOGICAL)
5196 {
5197 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
5198 arrayse1.expr, arrayse2.expr);
5199 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
5200 }
5201 else
5202 {
5203 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
5204 arrayse2.expr);
5205 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
5206 }
5207 gfc_add_modify (&block, resvar, tmp);
5208
5209 /* Finish up the loop block and the loop. */
5210 tmp = gfc_finish_block (&block);
5211 gfc_add_expr_to_block (&body, tmp);
5212
5213 gfc_trans_scalarizing_loops (&loop, &body);
5214 gfc_add_block_to_block (&se->pre, &loop.pre);
5215 gfc_add_block_to_block (&se->pre, &loop.post);
5216 gfc_cleanup_loop (&loop);
5217
5218 se->expr = resvar;
5219 }
5220
5221
5222 /* Remove unneeded kind= argument from actual argument list when the
5223 result conversion is dealt with in a different place. */
5224
5225 static void
strip_kind_from_actual(gfc_actual_arglist * actual)5226 strip_kind_from_actual (gfc_actual_arglist * actual)
5227 {
5228 for (gfc_actual_arglist *a = actual; a; a = a->next)
5229 {
5230 if (a && a->name && strcmp (a->name, "kind") == 0)
5231 {
5232 gfc_free_expr (a->expr);
5233 a->expr = NULL;
5234 }
5235 }
5236 }
5237
5238 /* Emit code for minloc or maxloc intrinsic. There are many different cases
5239 we need to handle. For performance reasons we sometimes create two
5240 loops instead of one, where the second one is much simpler.
5241 Examples for minloc intrinsic:
5242 1) Result is an array, a call is generated
5243 2) Array mask is used and NaNs need to be supported:
5244 limit = Infinity;
5245 pos = 0;
5246 S = from;
5247 while (S <= to) {
5248 if (mask[S]) {
5249 if (pos == 0) pos = S + (1 - from);
5250 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5251 }
5252 S++;
5253 }
5254 goto lab2;
5255 lab1:;
5256 while (S <= to) {
5257 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5258 S++;
5259 }
5260 lab2:;
5261 3) NaNs need to be supported, but it is known at compile time or cheaply
5262 at runtime whether array is nonempty or not:
5263 limit = Infinity;
5264 pos = 0;
5265 S = from;
5266 while (S <= to) {
5267 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5268 S++;
5269 }
5270 if (from <= to) pos = 1;
5271 goto lab2;
5272 lab1:;
5273 while (S <= to) {
5274 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5275 S++;
5276 }
5277 lab2:;
5278 4) NaNs aren't supported, array mask is used:
5279 limit = infinities_supported ? Infinity : huge (limit);
5280 pos = 0;
5281 S = from;
5282 while (S <= to) {
5283 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5284 S++;
5285 }
5286 goto lab2;
5287 lab1:;
5288 while (S <= to) {
5289 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5290 S++;
5291 }
5292 lab2:;
5293 5) Same without array mask:
5294 limit = infinities_supported ? Infinity : huge (limit);
5295 pos = (from <= to) ? 1 : 0;
5296 S = from;
5297 while (S <= to) {
5298 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5299 S++;
5300 }
5301 For 3) and 5), if mask is scalar, this all goes into a conditional,
5302 setting pos = 0; in the else branch.
5303
5304 Since we now also support the BACK argument, instead of using
5305 if (a[S] < limit), we now use
5306
5307 if (back)
5308 cond = a[S] <= limit;
5309 else
5310 cond = a[S] < limit;
5311 if (cond) {
5312 ....
5313
5314 The optimizer is smart enough to move the condition out of the loop.
5315 The are now marked as unlikely to for further speedup. */
5316
5317 static void
gfc_conv_intrinsic_minmaxloc(gfc_se * se,gfc_expr * expr,enum tree_code op)5318 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5319 {
5320 stmtblock_t body;
5321 stmtblock_t block;
5322 stmtblock_t ifblock;
5323 stmtblock_t elseblock;
5324 tree limit;
5325 tree type;
5326 tree tmp;
5327 tree cond;
5328 tree elsetmp;
5329 tree ifbody;
5330 tree offset;
5331 tree nonempty;
5332 tree lab1, lab2;
5333 tree b_if, b_else;
5334 gfc_loopinfo loop;
5335 gfc_actual_arglist *actual;
5336 gfc_ss *arrayss;
5337 gfc_ss *maskss;
5338 gfc_se arrayse;
5339 gfc_se maskse;
5340 gfc_expr *arrayexpr;
5341 gfc_expr *maskexpr;
5342 gfc_expr *backexpr;
5343 gfc_se backse;
5344 tree pos;
5345 int n;
5346 bool optional_mask;
5347
5348 actual = expr->value.function.actual;
5349
5350 /* The last argument, BACK, is passed by value. Ensure that
5351 by setting its name to %VAL. */
5352 for (gfc_actual_arglist *a = actual; a; a = a->next)
5353 {
5354 if (a->next == NULL)
5355 a->name = "%VAL";
5356 }
5357
5358 if (se->ss)
5359 {
5360 gfc_conv_intrinsic_funcall (se, expr);
5361 return;
5362 }
5363
5364 arrayexpr = actual->expr;
5365
5366 /* Special case for character maxloc. Remove unneeded actual
5367 arguments, then call a library function. */
5368
5369 if (arrayexpr->ts.type == BT_CHARACTER)
5370 {
5371 gfc_actual_arglist *a;
5372 a = actual;
5373 strip_kind_from_actual (a);
5374 while (a)
5375 {
5376 if (a->name && strcmp (a->name, "dim") == 0)
5377 {
5378 gfc_free_expr (a->expr);
5379 a->expr = NULL;
5380 }
5381 a = a->next;
5382 }
5383 gfc_conv_intrinsic_funcall (se, expr);
5384 return;
5385 }
5386
5387 /* Initialize the result. */
5388 pos = gfc_create_var (gfc_array_index_type, "pos");
5389 offset = gfc_create_var (gfc_array_index_type, "offset");
5390 type = gfc_typenode_for_spec (&expr->ts);
5391
5392 /* Walk the arguments. */
5393 arrayss = gfc_walk_expr (arrayexpr);
5394 gcc_assert (arrayss != gfc_ss_terminator);
5395
5396 actual = actual->next->next;
5397 gcc_assert (actual);
5398 maskexpr = actual->expr;
5399 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5400 && maskexpr->symtree->n.sym->attr.dummy
5401 && maskexpr->symtree->n.sym->attr.optional;
5402 backexpr = actual->next->next->expr;
5403 nonempty = NULL;
5404 if (maskexpr && maskexpr->rank != 0)
5405 {
5406 maskss = gfc_walk_expr (maskexpr);
5407 gcc_assert (maskss != gfc_ss_terminator);
5408 }
5409 else
5410 {
5411 mpz_t asize;
5412 if (gfc_array_size (arrayexpr, &asize))
5413 {
5414 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5415 mpz_clear (asize);
5416 nonempty = fold_build2_loc (input_location, GT_EXPR,
5417 logical_type_node, nonempty,
5418 gfc_index_zero_node);
5419 }
5420 maskss = NULL;
5421 }
5422
5423 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5424 switch (arrayexpr->ts.type)
5425 {
5426 case BT_REAL:
5427 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5428 break;
5429
5430 case BT_INTEGER:
5431 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5432 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5433 arrayexpr->ts.kind);
5434 break;
5435
5436 default:
5437 gcc_unreachable ();
5438 }
5439
5440 /* We start with the most negative possible value for MAXLOC, and the most
5441 positive possible value for MINLOC. The most negative possible value is
5442 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5443 possible value is HUGE in both cases. */
5444 if (op == GT_EXPR)
5445 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5446 if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5447 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5448 build_int_cst (TREE_TYPE (tmp), 1));
5449
5450 gfc_add_modify (&se->pre, limit, tmp);
5451
5452 /* Initialize the scalarizer. */
5453 gfc_init_loopinfo (&loop);
5454
5455 /* We add the mask first because the number of iterations is taken
5456 from the last ss, and this breaks if an absent optional argument
5457 is used for mask. */
5458
5459 if (maskss)
5460 gfc_add_ss_to_loop (&loop, maskss);
5461
5462 gfc_add_ss_to_loop (&loop, arrayss);
5463
5464 /* Initialize the loop. */
5465 gfc_conv_ss_startstride (&loop);
5466
5467 /* The code generated can have more than one loop in sequence (see the
5468 comment at the function header). This doesn't work well with the
5469 scalarizer, which changes arrays' offset when the scalarization loops
5470 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5471 are currently inlined in the scalar case only (for which loop is of rank
5472 one). As there is no dependency to care about in that case, there is no
5473 temporary, so that we can use the scalarizer temporary code to handle
5474 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5475 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5476 to restore offset.
5477 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5478 should eventually go away. We could either create two loops properly,
5479 or find another way to save/restore the array offsets between the two
5480 loops (without conflicting with temporary management), or use a single
5481 loop minmaxloc implementation. See PR 31067. */
5482 loop.temp_dim = loop.dimen;
5483 gfc_conv_loop_setup (&loop, &expr->where);
5484
5485 gcc_assert (loop.dimen == 1);
5486 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
5487 nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5488 loop.from[0], loop.to[0]);
5489
5490 lab1 = NULL;
5491 lab2 = NULL;
5492 /* Initialize the position to zero, following Fortran 2003. We are free
5493 to do this because Fortran 95 allows the result of an entirely false
5494 mask to be processor dependent. If we know at compile time the array
5495 is non-empty and no MASK is used, we can initialize to 1 to simplify
5496 the inner loop. */
5497 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5498 gfc_add_modify (&loop.pre, pos,
5499 fold_build3_loc (input_location, COND_EXPR,
5500 gfc_array_index_type,
5501 nonempty, gfc_index_one_node,
5502 gfc_index_zero_node));
5503 else
5504 {
5505 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
5506 lab1 = gfc_build_label_decl (NULL_TREE);
5507 TREE_USED (lab1) = 1;
5508 lab2 = gfc_build_label_decl (NULL_TREE);
5509 TREE_USED (lab2) = 1;
5510 }
5511
5512 /* An offset must be added to the loop
5513 counter to obtain the required position. */
5514 gcc_assert (loop.from[0]);
5515
5516 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5517 gfc_index_one_node, loop.from[0]);
5518 gfc_add_modify (&loop.pre, offset, tmp);
5519
5520 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5521 if (maskss)
5522 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5523 /* Generate the loop body. */
5524 gfc_start_scalarized_body (&loop, &body);
5525
5526 /* If we have a mask, only check this element if the mask is set. */
5527 if (maskss)
5528 {
5529 gfc_init_se (&maskse, NULL);
5530 gfc_copy_loopinfo_to_se (&maskse, &loop);
5531 maskse.ss = maskss;
5532 gfc_conv_expr_val (&maskse, maskexpr);
5533 gfc_add_block_to_block (&body, &maskse.pre);
5534
5535 gfc_start_block (&block);
5536 }
5537 else
5538 gfc_init_block (&block);
5539
5540 /* Compare with the current limit. */
5541 gfc_init_se (&arrayse, NULL);
5542 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5543 arrayse.ss = arrayss;
5544 gfc_conv_expr_val (&arrayse, arrayexpr);
5545 gfc_add_block_to_block (&block, &arrayse.pre);
5546
5547 gfc_init_se (&backse, NULL);
5548 gfc_conv_expr_val (&backse, backexpr);
5549 gfc_add_block_to_block (&block, &backse.pre);
5550
5551 /* We do the following if this is a more extreme value. */
5552 gfc_start_block (&ifblock);
5553
5554 /* Assign the value to the limit... */
5555 gfc_add_modify (&ifblock, limit, arrayse.expr);
5556
5557 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5558 {
5559 stmtblock_t ifblock2;
5560 tree ifbody2;
5561
5562 gfc_start_block (&ifblock2);
5563 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5564 loop.loopvar[0], offset);
5565 gfc_add_modify (&ifblock2, pos, tmp);
5566 ifbody2 = gfc_finish_block (&ifblock2);
5567 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos,
5568 gfc_index_zero_node);
5569 tmp = build3_v (COND_EXPR, cond, ifbody2,
5570 build_empty_stmt (input_location));
5571 gfc_add_expr_to_block (&block, tmp);
5572 }
5573
5574 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5575 loop.loopvar[0], offset);
5576 gfc_add_modify (&ifblock, pos, tmp);
5577
5578 if (lab1)
5579 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5580
5581 ifbody = gfc_finish_block (&ifblock);
5582
5583 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5584 {
5585 if (lab1)
5586 cond = fold_build2_loc (input_location,
5587 op == GT_EXPR ? GE_EXPR : LE_EXPR,
5588 logical_type_node, arrayse.expr, limit);
5589 else
5590 {
5591 tree ifbody2, elsebody2;
5592
5593 /* We switch to > or >= depending on the value of the BACK argument. */
5594 cond = gfc_create_var (logical_type_node, "cond");
5595
5596 gfc_start_block (&ifblock);
5597 b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5598 logical_type_node, arrayse.expr, limit);
5599
5600 gfc_add_modify (&ifblock, cond, b_if);
5601 ifbody2 = gfc_finish_block (&ifblock);
5602
5603 gfc_start_block (&elseblock);
5604 b_else = fold_build2_loc (input_location, op, logical_type_node,
5605 arrayse.expr, limit);
5606
5607 gfc_add_modify (&elseblock, cond, b_else);
5608 elsebody2 = gfc_finish_block (&elseblock);
5609
5610 tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5611 backse.expr, ifbody2, elsebody2);
5612
5613 gfc_add_expr_to_block (&block, tmp);
5614 }
5615
5616 cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5617 ifbody = build3_v (COND_EXPR, cond, ifbody,
5618 build_empty_stmt (input_location));
5619 }
5620 gfc_add_expr_to_block (&block, ifbody);
5621
5622 if (maskss)
5623 {
5624 /* We enclose the above in if (mask) {...}. If the mask is an
5625 optional argument, generate IF (.NOT. PRESENT(MASK)
5626 .OR. MASK(I)). */
5627
5628 tree ifmask;
5629 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5630 tmp = gfc_finish_block (&block);
5631 tmp = build3_v (COND_EXPR, ifmask, tmp,
5632 build_empty_stmt (input_location));
5633 }
5634 else
5635 tmp = gfc_finish_block (&block);
5636 gfc_add_expr_to_block (&body, tmp);
5637
5638 if (lab1)
5639 {
5640 gfc_trans_scalarized_loop_boundary (&loop, &body);
5641
5642 if (HONOR_NANS (DECL_MODE (limit)))
5643 {
5644 if (nonempty != NULL)
5645 {
5646 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
5647 tmp = build3_v (COND_EXPR, nonempty, ifbody,
5648 build_empty_stmt (input_location));
5649 gfc_add_expr_to_block (&loop.code[0], tmp);
5650 }
5651 }
5652
5653 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
5654 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
5655
5656 /* If we have a mask, only check this element if the mask is set. */
5657 if (maskss)
5658 {
5659 gfc_init_se (&maskse, NULL);
5660 gfc_copy_loopinfo_to_se (&maskse, &loop);
5661 maskse.ss = maskss;
5662 gfc_conv_expr_val (&maskse, maskexpr);
5663 gfc_add_block_to_block (&body, &maskse.pre);
5664
5665 gfc_start_block (&block);
5666 }
5667 else
5668 gfc_init_block (&block);
5669
5670 /* Compare with the current limit. */
5671 gfc_init_se (&arrayse, NULL);
5672 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5673 arrayse.ss = arrayss;
5674 gfc_conv_expr_val (&arrayse, arrayexpr);
5675 gfc_add_block_to_block (&block, &arrayse.pre);
5676
5677 /* We do the following if this is a more extreme value. */
5678 gfc_start_block (&ifblock);
5679
5680 /* Assign the value to the limit... */
5681 gfc_add_modify (&ifblock, limit, arrayse.expr);
5682
5683 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5684 loop.loopvar[0], offset);
5685 gfc_add_modify (&ifblock, pos, tmp);
5686
5687 ifbody = gfc_finish_block (&ifblock);
5688
5689 /* We switch to > or >= depending on the value of the BACK argument. */
5690 {
5691 tree ifbody2, elsebody2;
5692
5693 cond = gfc_create_var (logical_type_node, "cond");
5694
5695 gfc_start_block (&ifblock);
5696 b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5697 logical_type_node, arrayse.expr, limit);
5698
5699 gfc_add_modify (&ifblock, cond, b_if);
5700 ifbody2 = gfc_finish_block (&ifblock);
5701
5702 gfc_start_block (&elseblock);
5703 b_else = fold_build2_loc (input_location, op, logical_type_node,
5704 arrayse.expr, limit);
5705
5706 gfc_add_modify (&elseblock, cond, b_else);
5707 elsebody2 = gfc_finish_block (&elseblock);
5708
5709 tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5710 backse.expr, ifbody2, elsebody2);
5711 }
5712
5713 gfc_add_expr_to_block (&block, tmp);
5714 cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5715 tmp = build3_v (COND_EXPR, cond, ifbody,
5716 build_empty_stmt (input_location));
5717
5718 gfc_add_expr_to_block (&block, tmp);
5719
5720 if (maskss)
5721 {
5722 /* We enclose the above in if (mask) {...}. If the mask is
5723 an optional argument, generate IF (.NOT. PRESENT(MASK)
5724 .OR. MASK(I)).*/
5725
5726 tree ifmask;
5727 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5728 tmp = gfc_finish_block (&block);
5729 tmp = build3_v (COND_EXPR, ifmask, tmp,
5730 build_empty_stmt (input_location));
5731 }
5732 else
5733 tmp = gfc_finish_block (&block);
5734 gfc_add_expr_to_block (&body, tmp);
5735 /* Avoid initializing loopvar[0] again, it should be left where
5736 it finished by the first loop. */
5737 loop.from[0] = loop.loopvar[0];
5738 }
5739
5740 gfc_trans_scalarizing_loops (&loop, &body);
5741
5742 if (lab2)
5743 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
5744
5745 /* For a scalar mask, enclose the loop in an if statement. */
5746 if (maskexpr && maskss == NULL)
5747 {
5748 tree ifmask;
5749
5750 gfc_init_se (&maskse, NULL);
5751 gfc_conv_expr_val (&maskse, maskexpr);
5752 gfc_init_block (&block);
5753 gfc_add_block_to_block (&block, &loop.pre);
5754 gfc_add_block_to_block (&block, &loop.post);
5755 tmp = gfc_finish_block (&block);
5756
5757 /* For the else part of the scalar mask, just initialize
5758 the pos variable the same way as above. */
5759
5760 gfc_init_block (&elseblock);
5761 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
5762 elsetmp = gfc_finish_block (&elseblock);
5763 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5764 tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5765 gfc_add_expr_to_block (&block, tmp);
5766 gfc_add_block_to_block (&se->pre, &block);
5767 }
5768 else
5769 {
5770 gfc_add_block_to_block (&se->pre, &loop.pre);
5771 gfc_add_block_to_block (&se->pre, &loop.post);
5772 }
5773 gfc_cleanup_loop (&loop);
5774
5775 se->expr = convert (type, pos);
5776 }
5777
5778 /* Emit code for findloc. */
5779
5780 static void
gfc_conv_intrinsic_findloc(gfc_se * se,gfc_expr * expr)5781 gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5782 {
5783 gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5784 *kind_arg, *back_arg;
5785 gfc_expr *value_expr;
5786 int ikind;
5787 tree resvar;
5788 stmtblock_t block;
5789 stmtblock_t body;
5790 stmtblock_t loopblock;
5791 tree type;
5792 tree tmp;
5793 tree found;
5794 tree forward_branch = NULL_TREE;
5795 tree back_branch;
5796 gfc_loopinfo loop;
5797 gfc_ss *arrayss;
5798 gfc_ss *maskss;
5799 gfc_se arrayse;
5800 gfc_se valuese;
5801 gfc_se maskse;
5802 gfc_se backse;
5803 tree exit_label;
5804 gfc_expr *maskexpr;
5805 tree offset;
5806 int i;
5807 bool optional_mask;
5808
5809 array_arg = expr->value.function.actual;
5810 value_arg = array_arg->next;
5811 dim_arg = value_arg->next;
5812 mask_arg = dim_arg->next;
5813 kind_arg = mask_arg->next;
5814 back_arg = kind_arg->next;
5815
5816 /* Remove kind and set ikind. */
5817 if (kind_arg->expr)
5818 {
5819 ikind = mpz_get_si (kind_arg->expr->value.integer);
5820 gfc_free_expr (kind_arg->expr);
5821 kind_arg->expr = NULL;
5822 }
5823 else
5824 ikind = gfc_default_integer_kind;
5825
5826 value_expr = value_arg->expr;
5827
5828 /* Unless it's a string, pass VALUE by value. */
5829 if (value_expr->ts.type != BT_CHARACTER)
5830 value_arg->name = "%VAL";
5831
5832 /* Pass BACK argument by value. */
5833 back_arg->name = "%VAL";
5834
5835 /* Call the library if we have a character function or if
5836 rank > 0. */
5837 if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5838 {
5839 se->ignore_optional = 1;
5840 if (expr->rank == 0)
5841 {
5842 /* Remove dim argument. */
5843 gfc_free_expr (dim_arg->expr);
5844 dim_arg->expr = NULL;
5845 }
5846 gfc_conv_intrinsic_funcall (se, expr);
5847 return;
5848 }
5849
5850 type = gfc_get_int_type (ikind);
5851
5852 /* Initialize the result. */
5853 resvar = gfc_create_var (gfc_array_index_type, "pos");
5854 gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5855 offset = gfc_create_var (gfc_array_index_type, "offset");
5856
5857 maskexpr = mask_arg->expr;
5858 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5859 && maskexpr->symtree->n.sym->attr.dummy
5860 && maskexpr->symtree->n.sym->attr.optional;
5861
5862 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5863
5864 for (i = 0 ; i < 2; i++)
5865 {
5866 /* Walk the arguments. */
5867 arrayss = gfc_walk_expr (array_arg->expr);
5868 gcc_assert (arrayss != gfc_ss_terminator);
5869
5870 if (maskexpr && maskexpr->rank != 0)
5871 {
5872 maskss = gfc_walk_expr (maskexpr);
5873 gcc_assert (maskss != gfc_ss_terminator);
5874 }
5875 else
5876 maskss = NULL;
5877
5878 /* Initialize the scalarizer. */
5879 gfc_init_loopinfo (&loop);
5880 exit_label = gfc_build_label_decl (NULL_TREE);
5881 TREE_USED (exit_label) = 1;
5882
5883 /* We add the mask first because the number of iterations is
5884 taken from the last ss, and this breaks if an absent
5885 optional argument is used for mask. */
5886
5887 if (maskss)
5888 gfc_add_ss_to_loop (&loop, maskss);
5889 gfc_add_ss_to_loop (&loop, arrayss);
5890
5891 /* Initialize the loop. */
5892 gfc_conv_ss_startstride (&loop);
5893 gfc_conv_loop_setup (&loop, &expr->where);
5894
5895 /* Calculate the offset. */
5896 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5897 gfc_index_one_node, loop.from[0]);
5898 gfc_add_modify (&loop.pre, offset, tmp);
5899
5900 gfc_mark_ss_chain_used (arrayss, 1);
5901 if (maskss)
5902 gfc_mark_ss_chain_used (maskss, 1);
5903
5904 /* The first loop is for BACK=.true. */
5905 if (i == 0)
5906 loop.reverse[0] = GFC_REVERSE_SET;
5907
5908 /* Generate the loop body. */
5909 gfc_start_scalarized_body (&loop, &body);
5910
5911 /* If we have an array mask, only add the element if it is
5912 set. */
5913 if (maskss)
5914 {
5915 gfc_init_se (&maskse, NULL);
5916 gfc_copy_loopinfo_to_se (&maskse, &loop);
5917 maskse.ss = maskss;
5918 gfc_conv_expr_val (&maskse, maskexpr);
5919 gfc_add_block_to_block (&body, &maskse.pre);
5920 }
5921
5922 /* If the condition matches then set the return value. */
5923 gfc_start_block (&block);
5924
5925 /* Add the offset. */
5926 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5927 TREE_TYPE (resvar),
5928 loop.loopvar[0], offset);
5929 gfc_add_modify (&block, resvar, tmp);
5930 /* And break out of the loop. */
5931 tmp = build1_v (GOTO_EXPR, exit_label);
5932 gfc_add_expr_to_block (&block, tmp);
5933
5934 found = gfc_finish_block (&block);
5935
5936 /* Check this element. */
5937 gfc_init_se (&arrayse, NULL);
5938 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5939 arrayse.ss = arrayss;
5940 gfc_conv_expr_val (&arrayse, array_arg->expr);
5941 gfc_add_block_to_block (&body, &arrayse.pre);
5942
5943 gfc_init_se (&valuese, NULL);
5944 gfc_conv_expr_val (&valuese, value_arg->expr);
5945 gfc_add_block_to_block (&body, &valuese.pre);
5946
5947 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5948 arrayse.expr, valuese.expr);
5949
5950 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5951 if (maskss)
5952 {
5953 /* We enclose the above in if (mask) {...}. If the mask is
5954 an optional argument, generate IF (.NOT. PRESENT(MASK)
5955 .OR. MASK(I)). */
5956
5957 tree ifmask;
5958 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5959 tmp = build3_v (COND_EXPR, ifmask, tmp,
5960 build_empty_stmt (input_location));
5961 }
5962
5963 gfc_add_expr_to_block (&body, tmp);
5964 gfc_add_block_to_block (&body, &arrayse.post);
5965
5966 gfc_trans_scalarizing_loops (&loop, &body);
5967
5968 /* Add the exit label. */
5969 tmp = build1_v (LABEL_EXPR, exit_label);
5970 gfc_add_expr_to_block (&loop.pre, tmp);
5971 gfc_start_block (&loopblock);
5972 gfc_add_block_to_block (&loopblock, &loop.pre);
5973 gfc_add_block_to_block (&loopblock, &loop.post);
5974 if (i == 0)
5975 forward_branch = gfc_finish_block (&loopblock);
5976 else
5977 back_branch = gfc_finish_block (&loopblock);
5978
5979 gfc_cleanup_loop (&loop);
5980 }
5981
5982 /* Enclose the two loops in an IF statement. */
5983
5984 gfc_init_se (&backse, NULL);
5985 gfc_conv_expr_val (&backse, back_arg->expr);
5986 gfc_add_block_to_block (&se->pre, &backse.pre);
5987 tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5988
5989 /* For a scalar mask, enclose the loop in an if statement. */
5990 if (maskexpr && maskss == NULL)
5991 {
5992 tree ifmask;
5993 tree if_stmt;
5994
5995 gfc_init_se (&maskse, NULL);
5996 gfc_conv_expr_val (&maskse, maskexpr);
5997 gfc_init_block (&block);
5998 gfc_add_expr_to_block (&block, maskse.expr);
5999 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6000 if_stmt = build3_v (COND_EXPR, ifmask, tmp,
6001 build_empty_stmt (input_location));
6002 gfc_add_expr_to_block (&block, if_stmt);
6003 tmp = gfc_finish_block (&block);
6004 }
6005
6006 gfc_add_expr_to_block (&se->pre, tmp);
6007 se->expr = convert (type, resvar);
6008
6009 }
6010
6011 /* Emit code for minval or maxval intrinsic. There are many different cases
6012 we need to handle. For performance reasons we sometimes create two
6013 loops instead of one, where the second one is much simpler.
6014 Examples for minval intrinsic:
6015 1) Result is an array, a call is generated
6016 2) Array mask is used and NaNs need to be supported, rank 1:
6017 limit = Infinity;
6018 nonempty = false;
6019 S = from;
6020 while (S <= to) {
6021 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
6022 S++;
6023 }
6024 limit = nonempty ? NaN : huge (limit);
6025 lab:
6026 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6027 3) NaNs need to be supported, but it is known at compile time or cheaply
6028 at runtime whether array is nonempty or not, rank 1:
6029 limit = Infinity;
6030 S = from;
6031 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
6032 limit = (from <= to) ? NaN : huge (limit);
6033 lab:
6034 while (S <= to) { limit = min (a[S], limit); S++; }
6035 4) Array mask is used and NaNs need to be supported, rank > 1:
6036 limit = Infinity;
6037 nonempty = false;
6038 fast = false;
6039 S1 = from1;
6040 while (S1 <= to1) {
6041 S2 = from2;
6042 while (S2 <= to2) {
6043 if (mask[S1][S2]) {
6044 if (fast) limit = min (a[S1][S2], limit);
6045 else {
6046 nonempty = true;
6047 if (a[S1][S2] <= limit) {
6048 limit = a[S1][S2];
6049 fast = true;
6050 }
6051 }
6052 }
6053 S2++;
6054 }
6055 S1++;
6056 }
6057 if (!fast)
6058 limit = nonempty ? NaN : huge (limit);
6059 5) NaNs need to be supported, but it is known at compile time or cheaply
6060 at runtime whether array is nonempty or not, rank > 1:
6061 limit = Infinity;
6062 fast = false;
6063 S1 = from1;
6064 while (S1 <= to1) {
6065 S2 = from2;
6066 while (S2 <= to2) {
6067 if (fast) limit = min (a[S1][S2], limit);
6068 else {
6069 if (a[S1][S2] <= limit) {
6070 limit = a[S1][S2];
6071 fast = true;
6072 }
6073 }
6074 S2++;
6075 }
6076 S1++;
6077 }
6078 if (!fast)
6079 limit = (nonempty_array) ? NaN : huge (limit);
6080 6) NaNs aren't supported, but infinities are. Array mask is used:
6081 limit = Infinity;
6082 nonempty = false;
6083 S = from;
6084 while (S <= to) {
6085 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6086 S++;
6087 }
6088 limit = nonempty ? limit : huge (limit);
6089 7) Same without array mask:
6090 limit = Infinity;
6091 S = from;
6092 while (S <= to) { limit = min (a[S], limit); S++; }
6093 limit = (from <= to) ? limit : huge (limit);
6094 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6095 limit = huge (limit);
6096 S = from;
6097 while (S <= to) { limit = min (a[S], limit); S++); }
6098 (or
6099 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6100 with array mask instead).
6101 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6102 setting limit = huge (limit); in the else branch. */
6103
6104 static void
gfc_conv_intrinsic_minmaxval(gfc_se * se,gfc_expr * expr,enum tree_code op)6105 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6106 {
6107 tree limit;
6108 tree type;
6109 tree tmp;
6110 tree ifbody;
6111 tree nonempty;
6112 tree nonempty_var;
6113 tree lab;
6114 tree fast;
6115 tree huge_cst = NULL, nan_cst = NULL;
6116 stmtblock_t body;
6117 stmtblock_t block, block2;
6118 gfc_loopinfo loop;
6119 gfc_actual_arglist *actual;
6120 gfc_ss *arrayss;
6121 gfc_ss *maskss;
6122 gfc_se arrayse;
6123 gfc_se maskse;
6124 gfc_expr *arrayexpr;
6125 gfc_expr *maskexpr;
6126 int n;
6127 bool optional_mask;
6128
6129 if (se->ss)
6130 {
6131 gfc_conv_intrinsic_funcall (se, expr);
6132 return;
6133 }
6134
6135 actual = expr->value.function.actual;
6136 arrayexpr = actual->expr;
6137
6138 if (arrayexpr->ts.type == BT_CHARACTER)
6139 {
6140 gfc_actual_arglist *dim = actual->next;
6141 if (expr->rank == 0 && dim->expr != 0)
6142 {
6143 gfc_free_expr (dim->expr);
6144 dim->expr = NULL;
6145 }
6146 gfc_conv_intrinsic_funcall (se, expr);
6147 return;
6148 }
6149
6150 type = gfc_typenode_for_spec (&expr->ts);
6151 /* Initialize the result. */
6152 limit = gfc_create_var (type, "limit");
6153 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6154 switch (expr->ts.type)
6155 {
6156 case BT_REAL:
6157 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6158 expr->ts.kind, 0);
6159 if (HONOR_INFINITIES (DECL_MODE (limit)))
6160 {
6161 REAL_VALUE_TYPE real;
6162 real_inf (&real);
6163 tmp = build_real (type, real);
6164 }
6165 else
6166 tmp = huge_cst;
6167 if (HONOR_NANS (DECL_MODE (limit)))
6168 nan_cst = gfc_build_nan (type, "");
6169 break;
6170
6171 case BT_INTEGER:
6172 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6173 break;
6174
6175 default:
6176 gcc_unreachable ();
6177 }
6178
6179 /* We start with the most negative possible value for MAXVAL, and the most
6180 positive possible value for MINVAL. The most negative possible value is
6181 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6182 possible value is HUGE in both cases. */
6183 if (op == GT_EXPR)
6184 {
6185 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6186 if (huge_cst)
6187 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6188 TREE_TYPE (huge_cst), huge_cst);
6189 }
6190
6191 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6192 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6193 tmp, build_int_cst (type, 1));
6194
6195 gfc_add_modify (&se->pre, limit, tmp);
6196
6197 /* Walk the arguments. */
6198 arrayss = gfc_walk_expr (arrayexpr);
6199 gcc_assert (arrayss != gfc_ss_terminator);
6200
6201 actual = actual->next->next;
6202 gcc_assert (actual);
6203 maskexpr = actual->expr;
6204 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6205 && maskexpr->symtree->n.sym->attr.dummy
6206 && maskexpr->symtree->n.sym->attr.optional;
6207 nonempty = NULL;
6208 if (maskexpr && maskexpr->rank != 0)
6209 {
6210 maskss = gfc_walk_expr (maskexpr);
6211 gcc_assert (maskss != gfc_ss_terminator);
6212 }
6213 else
6214 {
6215 mpz_t asize;
6216 if (gfc_array_size (arrayexpr, &asize))
6217 {
6218 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6219 mpz_clear (asize);
6220 nonempty = fold_build2_loc (input_location, GT_EXPR,
6221 logical_type_node, nonempty,
6222 gfc_index_zero_node);
6223 }
6224 maskss = NULL;
6225 }
6226
6227 /* Initialize the scalarizer. */
6228 gfc_init_loopinfo (&loop);
6229
6230 /* We add the mask first because the number of iterations is taken
6231 from the last ss, and this breaks if an absent optional argument
6232 is used for mask. */
6233
6234 if (maskss)
6235 gfc_add_ss_to_loop (&loop, maskss);
6236 gfc_add_ss_to_loop (&loop, arrayss);
6237
6238 /* Initialize the loop. */
6239 gfc_conv_ss_startstride (&loop);
6240
6241 /* The code generated can have more than one loop in sequence (see the
6242 comment at the function header). This doesn't work well with the
6243 scalarizer, which changes arrays' offset when the scalarization loops
6244 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6245 are currently inlined in the scalar case only. As there is no dependency
6246 to care about in that case, there is no temporary, so that we can use the
6247 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6248 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6249 gfc_trans_scalarized_loop_boundary even later to restore offset.
6250 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6251 should eventually go away. We could either create two loops properly,
6252 or find another way to save/restore the array offsets between the two
6253 loops (without conflicting with temporary management), or use a single
6254 loop minmaxval implementation. See PR 31067. */
6255 loop.temp_dim = loop.dimen;
6256 gfc_conv_loop_setup (&loop, &expr->where);
6257
6258 if (nonempty == NULL && maskss == NULL
6259 && loop.dimen == 1 && loop.from[0] && loop.to[0])
6260 nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6261 loop.from[0], loop.to[0]);
6262 nonempty_var = NULL;
6263 if (nonempty == NULL
6264 && (HONOR_INFINITIES (DECL_MODE (limit))
6265 || HONOR_NANS (DECL_MODE (limit))))
6266 {
6267 nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6268 gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6269 nonempty = nonempty_var;
6270 }
6271 lab = NULL;
6272 fast = NULL;
6273 if (HONOR_NANS (DECL_MODE (limit)))
6274 {
6275 if (loop.dimen == 1)
6276 {
6277 lab = gfc_build_label_decl (NULL_TREE);
6278 TREE_USED (lab) = 1;
6279 }
6280 else
6281 {
6282 fast = gfc_create_var (logical_type_node, "fast");
6283 gfc_add_modify (&se->pre, fast, logical_false_node);
6284 }
6285 }
6286
6287 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6288 if (maskss)
6289 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6290 /* Generate the loop body. */
6291 gfc_start_scalarized_body (&loop, &body);
6292
6293 /* If we have a mask, only add this element if the mask is set. */
6294 if (maskss)
6295 {
6296 gfc_init_se (&maskse, NULL);
6297 gfc_copy_loopinfo_to_se (&maskse, &loop);
6298 maskse.ss = maskss;
6299 gfc_conv_expr_val (&maskse, maskexpr);
6300 gfc_add_block_to_block (&body, &maskse.pre);
6301
6302 gfc_start_block (&block);
6303 }
6304 else
6305 gfc_init_block (&block);
6306
6307 /* Compare with the current limit. */
6308 gfc_init_se (&arrayse, NULL);
6309 gfc_copy_loopinfo_to_se (&arrayse, &loop);
6310 arrayse.ss = arrayss;
6311 gfc_conv_expr_val (&arrayse, arrayexpr);
6312 gfc_add_block_to_block (&block, &arrayse.pre);
6313
6314 gfc_init_block (&block2);
6315
6316 if (nonempty_var)
6317 gfc_add_modify (&block2, nonempty_var, logical_true_node);
6318
6319 if (HONOR_NANS (DECL_MODE (limit)))
6320 {
6321 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6322 logical_type_node, arrayse.expr, limit);
6323 if (lab)
6324 ifbody = build1_v (GOTO_EXPR, lab);
6325 else
6326 {
6327 stmtblock_t ifblock;
6328
6329 gfc_init_block (&ifblock);
6330 gfc_add_modify (&ifblock, limit, arrayse.expr);
6331 gfc_add_modify (&ifblock, fast, logical_true_node);
6332 ifbody = gfc_finish_block (&ifblock);
6333 }
6334 tmp = build3_v (COND_EXPR, tmp, ifbody,
6335 build_empty_stmt (input_location));
6336 gfc_add_expr_to_block (&block2, tmp);
6337 }
6338 else
6339 {
6340 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6341 signed zeros. */
6342 tmp = fold_build2_loc (input_location,
6343 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6344 type, arrayse.expr, limit);
6345 gfc_add_modify (&block2, limit, tmp);
6346 }
6347
6348 if (fast)
6349 {
6350 tree elsebody = gfc_finish_block (&block2);
6351
6352 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6353 signed zeros. */
6354 if (HONOR_NANS (DECL_MODE (limit)))
6355 {
6356 tmp = fold_build2_loc (input_location, op, logical_type_node,
6357 arrayse.expr, limit);
6358 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6359 ifbody = build3_v (COND_EXPR, tmp, ifbody,
6360 build_empty_stmt (input_location));
6361 }
6362 else
6363 {
6364 tmp = fold_build2_loc (input_location,
6365 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6366 type, arrayse.expr, limit);
6367 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6368 }
6369 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6370 gfc_add_expr_to_block (&block, tmp);
6371 }
6372 else
6373 gfc_add_block_to_block (&block, &block2);
6374
6375 gfc_add_block_to_block (&block, &arrayse.post);
6376
6377 tmp = gfc_finish_block (&block);
6378 if (maskss)
6379 {
6380 /* We enclose the above in if (mask) {...}. If the mask is an
6381 optional argument, generate IF (.NOT. PRESENT(MASK)
6382 .OR. MASK(I)). */
6383 tree ifmask;
6384 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6385 tmp = build3_v (COND_EXPR, ifmask, tmp,
6386 build_empty_stmt (input_location));
6387 }
6388 gfc_add_expr_to_block (&body, tmp);
6389
6390 if (lab)
6391 {
6392 gfc_trans_scalarized_loop_boundary (&loop, &body);
6393
6394 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6395 nan_cst, huge_cst);
6396 gfc_add_modify (&loop.code[0], limit, tmp);
6397 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6398
6399 /* If we have a mask, only add this element if the mask is set. */
6400 if (maskss)
6401 {
6402 gfc_init_se (&maskse, NULL);
6403 gfc_copy_loopinfo_to_se (&maskse, &loop);
6404 maskse.ss = maskss;
6405 gfc_conv_expr_val (&maskse, maskexpr);
6406 gfc_add_block_to_block (&body, &maskse.pre);
6407
6408 gfc_start_block (&block);
6409 }
6410 else
6411 gfc_init_block (&block);
6412
6413 /* Compare with the current limit. */
6414 gfc_init_se (&arrayse, NULL);
6415 gfc_copy_loopinfo_to_se (&arrayse, &loop);
6416 arrayse.ss = arrayss;
6417 gfc_conv_expr_val (&arrayse, arrayexpr);
6418 gfc_add_block_to_block (&block, &arrayse.pre);
6419
6420 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6421 signed zeros. */
6422 if (HONOR_NANS (DECL_MODE (limit)))
6423 {
6424 tmp = fold_build2_loc (input_location, op, logical_type_node,
6425 arrayse.expr, limit);
6426 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6427 tmp = build3_v (COND_EXPR, tmp, ifbody,
6428 build_empty_stmt (input_location));
6429 gfc_add_expr_to_block (&block, tmp);
6430 }
6431 else
6432 {
6433 tmp = fold_build2_loc (input_location,
6434 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6435 type, arrayse.expr, limit);
6436 gfc_add_modify (&block, limit, tmp);
6437 }
6438
6439 gfc_add_block_to_block (&block, &arrayse.post);
6440
6441 tmp = gfc_finish_block (&block);
6442 if (maskss)
6443 /* We enclose the above in if (mask) {...}. */
6444 {
6445 tree ifmask;
6446 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6447 tmp = build3_v (COND_EXPR, ifmask, tmp,
6448 build_empty_stmt (input_location));
6449 }
6450
6451 gfc_add_expr_to_block (&body, tmp);
6452 /* Avoid initializing loopvar[0] again, it should be left where
6453 it finished by the first loop. */
6454 loop.from[0] = loop.loopvar[0];
6455 }
6456 gfc_trans_scalarizing_loops (&loop, &body);
6457
6458 if (fast)
6459 {
6460 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6461 nan_cst, huge_cst);
6462 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6463 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6464 ifbody);
6465 gfc_add_expr_to_block (&loop.pre, tmp);
6466 }
6467 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6468 {
6469 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6470 huge_cst);
6471 gfc_add_modify (&loop.pre, limit, tmp);
6472 }
6473
6474 /* For a scalar mask, enclose the loop in an if statement. */
6475 if (maskexpr && maskss == NULL)
6476 {
6477 tree else_stmt;
6478 tree ifmask;
6479
6480 gfc_init_se (&maskse, NULL);
6481 gfc_conv_expr_val (&maskse, maskexpr);
6482 gfc_init_block (&block);
6483 gfc_add_block_to_block (&block, &loop.pre);
6484 gfc_add_block_to_block (&block, &loop.post);
6485 tmp = gfc_finish_block (&block);
6486
6487 if (HONOR_INFINITIES (DECL_MODE (limit)))
6488 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6489 else
6490 else_stmt = build_empty_stmt (input_location);
6491
6492 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6493 tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6494 gfc_add_expr_to_block (&block, tmp);
6495 gfc_add_block_to_block (&se->pre, &block);
6496 }
6497 else
6498 {
6499 gfc_add_block_to_block (&se->pre, &loop.pre);
6500 gfc_add_block_to_block (&se->pre, &loop.post);
6501 }
6502
6503 gfc_cleanup_loop (&loop);
6504
6505 se->expr = limit;
6506 }
6507
6508 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6509 static void
gfc_conv_intrinsic_btest(gfc_se * se,gfc_expr * expr)6510 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6511 {
6512 tree args[2];
6513 tree type;
6514 tree tmp;
6515
6516 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6517 type = TREE_TYPE (args[0]);
6518
6519 /* Optionally generate code for runtime argument check. */
6520 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6521 {
6522 tree below = fold_build2_loc (input_location, LT_EXPR,
6523 logical_type_node, args[1],
6524 build_int_cst (TREE_TYPE (args[1]), 0));
6525 tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6526 tree above = fold_build2_loc (input_location, GE_EXPR,
6527 logical_type_node, args[1], nbits);
6528 tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6529 logical_type_node, below, above);
6530 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6531 "POS argument (%ld) out of range 0:%ld "
6532 "in intrinsic BTEST",
6533 fold_convert (long_integer_type_node, args[1]),
6534 fold_convert (long_integer_type_node, nbits));
6535 }
6536
6537 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6538 build_int_cst (type, 1), args[1]);
6539 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6540 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6541 build_int_cst (type, 0));
6542 type = gfc_typenode_for_spec (&expr->ts);
6543 se->expr = convert (type, tmp);
6544 }
6545
6546
6547 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6548 static void
gfc_conv_intrinsic_bitcomp(gfc_se * se,gfc_expr * expr,enum tree_code op)6549 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6550 {
6551 tree args[2];
6552
6553 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6554
6555 /* Convert both arguments to the unsigned type of the same size. */
6556 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6557 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6558
6559 /* If they have unequal type size, convert to the larger one. */
6560 if (TYPE_PRECISION (TREE_TYPE (args[0]))
6561 > TYPE_PRECISION (TREE_TYPE (args[1])))
6562 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6563 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6564 > TYPE_PRECISION (TREE_TYPE (args[0])))
6565 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6566
6567 /* Now, we compare them. */
6568 se->expr = fold_build2_loc (input_location, op, logical_type_node,
6569 args[0], args[1]);
6570 }
6571
6572
6573 /* Generate code to perform the specified operation. */
6574 static void
gfc_conv_intrinsic_bitop(gfc_se * se,gfc_expr * expr,enum tree_code op)6575 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6576 {
6577 tree args[2];
6578
6579 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6580 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6581 args[0], args[1]);
6582 }
6583
6584 /* Bitwise not. */
6585 static void
gfc_conv_intrinsic_not(gfc_se * se,gfc_expr * expr)6586 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6587 {
6588 tree arg;
6589
6590 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6591 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6592 TREE_TYPE (arg), arg);
6593 }
6594
6595 /* Set or clear a single bit. */
6596 static void
gfc_conv_intrinsic_singlebitop(gfc_se * se,gfc_expr * expr,int set)6597 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6598 {
6599 tree args[2];
6600 tree type;
6601 tree tmp;
6602 enum tree_code op;
6603
6604 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6605 type = TREE_TYPE (args[0]);
6606
6607 /* Optionally generate code for runtime argument check. */
6608 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6609 {
6610 tree below = fold_build2_loc (input_location, LT_EXPR,
6611 logical_type_node, args[1],
6612 build_int_cst (TREE_TYPE (args[1]), 0));
6613 tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6614 tree above = fold_build2_loc (input_location, GE_EXPR,
6615 logical_type_node, args[1], nbits);
6616 tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6617 logical_type_node, below, above);
6618 size_t len_name = strlen (expr->value.function.isym->name);
6619 char *name = XALLOCAVEC (char, len_name + 1);
6620 for (size_t i = 0; i < len_name; i++)
6621 name[i] = TOUPPER (expr->value.function.isym->name[i]);
6622 name[len_name] = '\0';
6623 tree iname = gfc_build_addr_expr (pchar_type_node,
6624 gfc_build_cstring_const (name));
6625 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6626 "POS argument (%ld) out of range 0:%ld "
6627 "in intrinsic %s",
6628 fold_convert (long_integer_type_node, args[1]),
6629 fold_convert (long_integer_type_node, nbits),
6630 iname);
6631 }
6632
6633 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6634 build_int_cst (type, 1), args[1]);
6635 if (set)
6636 op = BIT_IOR_EXPR;
6637 else
6638 {
6639 op = BIT_AND_EXPR;
6640 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6641 }
6642 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6643 }
6644
6645 /* Extract a sequence of bits.
6646 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6647 static void
gfc_conv_intrinsic_ibits(gfc_se * se,gfc_expr * expr)6648 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6649 {
6650 tree args[3];
6651 tree type;
6652 tree tmp;
6653 tree mask;
6654
6655 gfc_conv_intrinsic_function_args (se, expr, args, 3);
6656 type = TREE_TYPE (args[0]);
6657
6658 /* Optionally generate code for runtime argument check. */
6659 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6660 {
6661 tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6662 tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6663 tree nbits = build_int_cst (long_integer_type_node,
6664 TYPE_PRECISION (type));
6665 tree below = fold_build2_loc (input_location, LT_EXPR,
6666 logical_type_node, args[1],
6667 build_int_cst (TREE_TYPE (args[1]), 0));
6668 tree above = fold_build2_loc (input_location, GT_EXPR,
6669 logical_type_node, tmp1, nbits);
6670 tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6671 logical_type_node, below, above);
6672 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6673 "POS argument (%ld) out of range 0:%ld "
6674 "in intrinsic IBITS", tmp1, nbits);
6675 below = fold_build2_loc (input_location, LT_EXPR,
6676 logical_type_node, args[2],
6677 build_int_cst (TREE_TYPE (args[2]), 0));
6678 above = fold_build2_loc (input_location, GT_EXPR,
6679 logical_type_node, tmp2, nbits);
6680 scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6681 logical_type_node, below, above);
6682 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6683 "LEN argument (%ld) out of range 0:%ld "
6684 "in intrinsic IBITS", tmp2, nbits);
6685 above = fold_build2_loc (input_location, PLUS_EXPR,
6686 long_integer_type_node, tmp1, tmp2);
6687 scond = fold_build2_loc (input_location, GT_EXPR,
6688 logical_type_node, above, nbits);
6689 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6690 "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6691 "in intrinsic IBITS", tmp1, tmp2, nbits);
6692 }
6693
6694 mask = build_int_cst (type, -1);
6695 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6696 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6697
6698 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6699
6700 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6701 }
6702
6703 static void
gfc_conv_intrinsic_shape(gfc_se * se,gfc_expr * expr)6704 gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
6705 {
6706 gfc_actual_arglist *s, *k;
6707 gfc_expr *e;
6708 gfc_array_spec *as;
6709 gfc_ss *ss;
6710
6711 /* Remove the KIND argument, if present. */
6712 s = expr->value.function.actual;
6713 k = s->next;
6714 e = k->expr;
6715 gfc_free_expr (e);
6716 k->expr = NULL;
6717
6718 gfc_conv_intrinsic_funcall (se, expr);
6719
6720 as = gfc_get_full_arrayspec_from_expr (s->expr);;
6721 ss = gfc_walk_expr (s->expr);
6722
6723 /* According to F2018 16.9.172, para 5, an assumed rank entity, argument
6724 associated with an assumed size array, has the ubound of the final
6725 dimension set to -1 and SHAPE must return this. */
6726 if (as && as->type == AS_ASSUMED_RANK
6727 && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))
6728 && ss && ss->info->type == GFC_SS_SECTION)
6729 {
6730 tree desc, rank, minus_one, cond, ubound, tmp;
6731 stmtblock_t block;
6732 gfc_se ase;
6733
6734 minus_one = build_int_cst (gfc_array_index_type, -1);
6735
6736 /* Recover the descriptor for the array. */
6737 gfc_init_se (&ase, NULL);
6738 ase.descriptor_only = 1;
6739 gfc_conv_expr_lhs (&ase, ss->info->expr);
6740
6741 /* Obtain rank-1 so that we can address both descriptors. */
6742 rank = gfc_conv_descriptor_rank (ase.expr);
6743 rank = fold_convert (gfc_array_index_type, rank);
6744 rank = fold_build2_loc (input_location, PLUS_EXPR,
6745 gfc_array_index_type,
6746 rank, minus_one);
6747 rank = gfc_evaluate_now (rank, &se->pre);
6748
6749 /* The ubound for the final dimension will be tested for being -1. */
6750 ubound = gfc_conv_descriptor_ubound_get (ase.expr, rank);
6751 ubound = gfc_evaluate_now (ubound, &se->pre);
6752 cond = fold_build2_loc (input_location, EQ_EXPR,
6753 logical_type_node,
6754 ubound, minus_one);
6755
6756 /* Obtain the last element of the result from the library shape
6757 intrinsic and set it to -1 if that is the value of ubound. */
6758 desc = se->expr;
6759 tmp = gfc_conv_array_data (desc);
6760 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6761 tmp = gfc_build_array_ref (tmp, rank, NULL, NULL);
6762
6763 gfc_init_block (&block);
6764 gfc_add_modify (&block, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6765
6766 cond = build3_v (COND_EXPR, cond,
6767 gfc_finish_block (&block),
6768 build_empty_stmt (input_location));
6769 gfc_add_expr_to_block (&se->pre, cond);
6770 }
6771
6772 }
6773
6774 static void
gfc_conv_intrinsic_shift(gfc_se * se,gfc_expr * expr,bool right_shift,bool arithmetic)6775 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6776 bool arithmetic)
6777 {
6778 tree args[2], type, num_bits, cond;
6779 tree bigshift;
6780
6781 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6782
6783 args[0] = gfc_evaluate_now (args[0], &se->pre);
6784 args[1] = gfc_evaluate_now (args[1], &se->pre);
6785 type = TREE_TYPE (args[0]);
6786
6787 if (!arithmetic)
6788 args[0] = fold_convert (unsigned_type_for (type), args[0]);
6789 else
6790 gcc_assert (right_shift);
6791
6792 se->expr = fold_build2_loc (input_location,
6793 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
6794 TREE_TYPE (args[0]), args[0], args[1]);
6795
6796 if (!arithmetic)
6797 se->expr = fold_convert (type, se->expr);
6798
6799 if (!arithmetic)
6800 bigshift = build_int_cst (type, 0);
6801 else
6802 {
6803 tree nonneg = fold_build2_loc (input_location, GE_EXPR,
6804 logical_type_node, args[0],
6805 build_int_cst (TREE_TYPE (args[0]), 0));
6806 bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
6807 build_int_cst (type, 0),
6808 build_int_cst (type, -1));
6809 }
6810
6811 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6812 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6813 special case. */
6814 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6815
6816 /* Optionally generate code for runtime argument check. */
6817 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6818 {
6819 tree below = fold_build2_loc (input_location, LT_EXPR,
6820 logical_type_node, args[1],
6821 build_int_cst (TREE_TYPE (args[1]), 0));
6822 tree above = fold_build2_loc (input_location, GT_EXPR,
6823 logical_type_node, args[1], num_bits);
6824 tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6825 logical_type_node, below, above);
6826 size_t len_name = strlen (expr->value.function.isym->name);
6827 char *name = XALLOCAVEC (char, len_name + 1);
6828 for (size_t i = 0; i < len_name; i++)
6829 name[i] = TOUPPER (expr->value.function.isym->name[i]);
6830 name[len_name] = '\0';
6831 tree iname = gfc_build_addr_expr (pchar_type_node,
6832 gfc_build_cstring_const (name));
6833 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6834 "SHIFT argument (%ld) out of range 0:%ld "
6835 "in intrinsic %s",
6836 fold_convert (long_integer_type_node, args[1]),
6837 fold_convert (long_integer_type_node, num_bits),
6838 iname);
6839 }
6840
6841 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6842 args[1], num_bits);
6843
6844 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6845 bigshift, se->expr);
6846 }
6847
6848 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6849 ? 0
6850 : ((shift >= 0) ? i << shift : i >> -shift)
6851 where all shifts are logical shifts. */
6852 static void
gfc_conv_intrinsic_ishft(gfc_se * se,gfc_expr * expr)6853 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
6854 {
6855 tree args[2];
6856 tree type;
6857 tree utype;
6858 tree tmp;
6859 tree width;
6860 tree num_bits;
6861 tree cond;
6862 tree lshift;
6863 tree rshift;
6864
6865 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6866
6867 args[0] = gfc_evaluate_now (args[0], &se->pre);
6868 args[1] = gfc_evaluate_now (args[1], &se->pre);
6869
6870 type = TREE_TYPE (args[0]);
6871 utype = unsigned_type_for (type);
6872
6873 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
6874 args[1]);
6875
6876 /* Left shift if positive. */
6877 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
6878
6879 /* Right shift if negative.
6880 We convert to an unsigned type because we want a logical shift.
6881 The standard doesn't define the case of shifting negative
6882 numbers, and we try to be compatible with other compilers, most
6883 notably g77, here. */
6884 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
6885 utype, convert (utype, args[0]), width));
6886
6887 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
6888 build_int_cst (TREE_TYPE (args[1]), 0));
6889 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
6890
6891 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6892 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6893 special case. */
6894 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6895
6896 /* Optionally generate code for runtime argument check. */
6897 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6898 {
6899 tree outside = fold_build2_loc (input_location, GT_EXPR,
6900 logical_type_node, width, num_bits);
6901 gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
6902 "SHIFT argument (%ld) out of range -%ld:%ld "
6903 "in intrinsic ISHFT",
6904 fold_convert (long_integer_type_node, args[1]),
6905 fold_convert (long_integer_type_node, num_bits),
6906 fold_convert (long_integer_type_node, num_bits));
6907 }
6908
6909 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
6910 num_bits);
6911 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6912 build_int_cst (type, 0), tmp);
6913 }
6914
6915
6916 /* Circular shift. AKA rotate or barrel shift. */
6917
6918 static void
gfc_conv_intrinsic_ishftc(gfc_se * se,gfc_expr * expr)6919 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
6920 {
6921 tree *args;
6922 tree type;
6923 tree tmp;
6924 tree lrot;
6925 tree rrot;
6926 tree zero;
6927 tree nbits;
6928 unsigned int num_args;
6929
6930 num_args = gfc_intrinsic_argument_list_length (expr);
6931 args = XALLOCAVEC (tree, num_args);
6932
6933 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6934
6935 type = TREE_TYPE (args[0]);
6936 nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
6937
6938 if (num_args == 3)
6939 {
6940 /* Use a library function for the 3 parameter version. */
6941 tree int4type = gfc_get_int_type (4);
6942
6943 /* We convert the first argument to at least 4 bytes, and
6944 convert back afterwards. This removes the need for library
6945 functions for all argument sizes, and function will be
6946 aligned to at least 32 bits, so there's no loss. */
6947 if (expr->ts.kind < 4)
6948 args[0] = convert (int4type, args[0]);
6949
6950 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6951 need loads of library functions. They cannot have values >
6952 BIT_SIZE (I) so the conversion is safe. */
6953 args[1] = convert (int4type, args[1]);
6954 args[2] = convert (int4type, args[2]);
6955
6956 /* Optionally generate code for runtime argument check. */
6957 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6958 {
6959 tree size = fold_convert (long_integer_type_node, args[2]);
6960 tree below = fold_build2_loc (input_location, LE_EXPR,
6961 logical_type_node, size,
6962 build_int_cst (TREE_TYPE (args[1]), 0));
6963 tree above = fold_build2_loc (input_location, GT_EXPR,
6964 logical_type_node, size, nbits);
6965 tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6966 logical_type_node, below, above);
6967 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6968 "SIZE argument (%ld) out of range 1:%ld "
6969 "in intrinsic ISHFTC", size, nbits);
6970 tree width = fold_convert (long_integer_type_node, args[1]);
6971 width = fold_build1_loc (input_location, ABS_EXPR,
6972 long_integer_type_node, width);
6973 scond = fold_build2_loc (input_location, GT_EXPR,
6974 logical_type_node, width, size);
6975 gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6976 "SHIFT argument (%ld) out of range -%ld:%ld "
6977 "in intrinsic ISHFTC",
6978 fold_convert (long_integer_type_node, args[1]),
6979 size, size);
6980 }
6981
6982 switch (expr->ts.kind)
6983 {
6984 case 1:
6985 case 2:
6986 case 4:
6987 tmp = gfor_fndecl_math_ishftc4;
6988 break;
6989 case 8:
6990 tmp = gfor_fndecl_math_ishftc8;
6991 break;
6992 case 16:
6993 tmp = gfor_fndecl_math_ishftc16;
6994 break;
6995 default:
6996 gcc_unreachable ();
6997 }
6998 se->expr = build_call_expr_loc (input_location,
6999 tmp, 3, args[0], args[1], args[2]);
7000 /* Convert the result back to the original type, if we extended
7001 the first argument's width above. */
7002 if (expr->ts.kind < 4)
7003 se->expr = convert (type, se->expr);
7004
7005 return;
7006 }
7007
7008 /* Evaluate arguments only once. */
7009 args[0] = gfc_evaluate_now (args[0], &se->pre);
7010 args[1] = gfc_evaluate_now (args[1], &se->pre);
7011
7012 /* Optionally generate code for runtime argument check. */
7013 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7014 {
7015 tree width = fold_convert (long_integer_type_node, args[1]);
7016 width = fold_build1_loc (input_location, ABS_EXPR,
7017 long_integer_type_node, width);
7018 tree outside = fold_build2_loc (input_location, GT_EXPR,
7019 logical_type_node, width, nbits);
7020 gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7021 "SHIFT argument (%ld) out of range -%ld:%ld "
7022 "in intrinsic ISHFTC",
7023 fold_convert (long_integer_type_node, args[1]),
7024 nbits, nbits);
7025 }
7026
7027 /* Rotate left if positive. */
7028 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7029
7030 /* Rotate right if negative. */
7031 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7032 args[1]);
7033 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7034
7035 zero = build_int_cst (TREE_TYPE (args[1]), 0);
7036 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7037 zero);
7038 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7039
7040 /* Do nothing if shift == 0. */
7041 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7042 zero);
7043 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7044 rrot);
7045 }
7046
7047
7048 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7049 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7050
7051 The conditional expression is necessary because the result of LEADZ(0)
7052 is defined, but the result of __builtin_clz(0) is undefined for most
7053 targets.
7054
7055 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7056 difference in bit size between the argument of LEADZ and the C int. */
7057
7058 static void
gfc_conv_intrinsic_leadz(gfc_se * se,gfc_expr * expr)7059 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7060 {
7061 tree arg;
7062 tree arg_type;
7063 tree cond;
7064 tree result_type;
7065 tree leadz;
7066 tree bit_size;
7067 tree tmp;
7068 tree func;
7069 int s, argsize;
7070
7071 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7072 argsize = TYPE_PRECISION (TREE_TYPE (arg));
7073
7074 /* Which variant of __builtin_clz* should we call? */
7075 if (argsize <= INT_TYPE_SIZE)
7076 {
7077 arg_type = unsigned_type_node;
7078 func = builtin_decl_explicit (BUILT_IN_CLZ);
7079 }
7080 else if (argsize <= LONG_TYPE_SIZE)
7081 {
7082 arg_type = long_unsigned_type_node;
7083 func = builtin_decl_explicit (BUILT_IN_CLZL);
7084 }
7085 else if (argsize <= LONG_LONG_TYPE_SIZE)
7086 {
7087 arg_type = long_long_unsigned_type_node;
7088 func = builtin_decl_explicit (BUILT_IN_CLZLL);
7089 }
7090 else
7091 {
7092 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7093 arg_type = gfc_build_uint_type (argsize);
7094 func = NULL_TREE;
7095 }
7096
7097 /* Convert the actual argument twice: first, to the unsigned type of the
7098 same size; then, to the proper argument type for the built-in
7099 function. But the return type is of the default INTEGER kind. */
7100 arg = fold_convert (gfc_build_uint_type (argsize), arg);
7101 arg = fold_convert (arg_type, arg);
7102 arg = gfc_evaluate_now (arg, &se->pre);
7103 result_type = gfc_get_int_type (gfc_default_integer_kind);
7104
7105 /* Compute LEADZ for the case i .ne. 0. */
7106 if (func)
7107 {
7108 s = TYPE_PRECISION (arg_type) - argsize;
7109 tmp = fold_convert (result_type,
7110 build_call_expr_loc (input_location, func,
7111 1, arg));
7112 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7113 tmp, build_int_cst (result_type, s));
7114 }
7115 else
7116 {
7117 /* We end up here if the argument type is larger than 'long long'.
7118 We generate this code:
7119
7120 if (x & (ULL_MAX << ULL_SIZE) != 0)
7121 return clzll ((unsigned long long) (x >> ULLSIZE));
7122 else
7123 return ULL_SIZE + clzll ((unsigned long long) x);
7124 where ULL_MAX is the largest value that a ULL_MAX can hold
7125 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7126 is the bit-size of the long long type (64 in this example). */
7127 tree ullsize, ullmax, tmp1, tmp2, btmp;
7128
7129 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7130 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7131 long_long_unsigned_type_node,
7132 build_int_cst (long_long_unsigned_type_node,
7133 0));
7134
7135 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7136 fold_convert (arg_type, ullmax), ullsize);
7137 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7138 arg, cond);
7139 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7140 cond, build_int_cst (arg_type, 0));
7141
7142 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7143 arg, ullsize);
7144 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7145 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7146 tmp1 = fold_convert (result_type,
7147 build_call_expr_loc (input_location, btmp, 1, tmp1));
7148
7149 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7150 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7151 tmp2 = fold_convert (result_type,
7152 build_call_expr_loc (input_location, btmp, 1, tmp2));
7153 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7154 tmp2, ullsize);
7155
7156 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7157 cond, tmp1, tmp2);
7158 }
7159
7160 /* Build BIT_SIZE. */
7161 bit_size = build_int_cst (result_type, argsize);
7162
7163 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7164 arg, build_int_cst (arg_type, 0));
7165 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7166 bit_size, leadz);
7167 }
7168
7169
7170 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7171
7172 The conditional expression is necessary because the result of TRAILZ(0)
7173 is defined, but the result of __builtin_ctz(0) is undefined for most
7174 targets. */
7175
7176 static void
gfc_conv_intrinsic_trailz(gfc_se * se,gfc_expr * expr)7177 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7178 {
7179 tree arg;
7180 tree arg_type;
7181 tree cond;
7182 tree result_type;
7183 tree trailz;
7184 tree bit_size;
7185 tree func;
7186 int argsize;
7187
7188 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7189 argsize = TYPE_PRECISION (TREE_TYPE (arg));
7190
7191 /* Which variant of __builtin_ctz* should we call? */
7192 if (argsize <= INT_TYPE_SIZE)
7193 {
7194 arg_type = unsigned_type_node;
7195 func = builtin_decl_explicit (BUILT_IN_CTZ);
7196 }
7197 else if (argsize <= LONG_TYPE_SIZE)
7198 {
7199 arg_type = long_unsigned_type_node;
7200 func = builtin_decl_explicit (BUILT_IN_CTZL);
7201 }
7202 else if (argsize <= LONG_LONG_TYPE_SIZE)
7203 {
7204 arg_type = long_long_unsigned_type_node;
7205 func = builtin_decl_explicit (BUILT_IN_CTZLL);
7206 }
7207 else
7208 {
7209 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7210 arg_type = gfc_build_uint_type (argsize);
7211 func = NULL_TREE;
7212 }
7213
7214 /* Convert the actual argument twice: first, to the unsigned type of the
7215 same size; then, to the proper argument type for the built-in
7216 function. But the return type is of the default INTEGER kind. */
7217 arg = fold_convert (gfc_build_uint_type (argsize), arg);
7218 arg = fold_convert (arg_type, arg);
7219 arg = gfc_evaluate_now (arg, &se->pre);
7220 result_type = gfc_get_int_type (gfc_default_integer_kind);
7221
7222 /* Compute TRAILZ for the case i .ne. 0. */
7223 if (func)
7224 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7225 func, 1, arg));
7226 else
7227 {
7228 /* We end up here if the argument type is larger than 'long long'.
7229 We generate this code:
7230
7231 if ((x & ULL_MAX) == 0)
7232 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7233 else
7234 return ctzll ((unsigned long long) x);
7235
7236 where ULL_MAX is the largest value that a ULL_MAX can hold
7237 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7238 is the bit-size of the long long type (64 in this example). */
7239 tree ullsize, ullmax, tmp1, tmp2, btmp;
7240
7241 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7242 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7243 long_long_unsigned_type_node,
7244 build_int_cst (long_long_unsigned_type_node, 0));
7245
7246 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7247 fold_convert (arg_type, ullmax));
7248 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7249 build_int_cst (arg_type, 0));
7250
7251 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7252 arg, ullsize);
7253 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7254 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7255 tmp1 = fold_convert (result_type,
7256 build_call_expr_loc (input_location, btmp, 1, tmp1));
7257 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7258 tmp1, ullsize);
7259
7260 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7261 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7262 tmp2 = fold_convert (result_type,
7263 build_call_expr_loc (input_location, btmp, 1, tmp2));
7264
7265 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7266 cond, tmp1, tmp2);
7267 }
7268
7269 /* Build BIT_SIZE. */
7270 bit_size = build_int_cst (result_type, argsize);
7271
7272 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7273 arg, build_int_cst (arg_type, 0));
7274 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7275 bit_size, trailz);
7276 }
7277
7278 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7279 for types larger than "long long", we call the long long built-in for
7280 the lower and higher bits and combine the result. */
7281
7282 static void
gfc_conv_intrinsic_popcnt_poppar(gfc_se * se,gfc_expr * expr,int parity)7283 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7284 {
7285 tree arg;
7286 tree arg_type;
7287 tree result_type;
7288 tree func;
7289 int argsize;
7290
7291 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7292 argsize = TYPE_PRECISION (TREE_TYPE (arg));
7293 result_type = gfc_get_int_type (gfc_default_integer_kind);
7294
7295 /* Which variant of the builtin should we call? */
7296 if (argsize <= INT_TYPE_SIZE)
7297 {
7298 arg_type = unsigned_type_node;
7299 func = builtin_decl_explicit (parity
7300 ? BUILT_IN_PARITY
7301 : BUILT_IN_POPCOUNT);
7302 }
7303 else if (argsize <= LONG_TYPE_SIZE)
7304 {
7305 arg_type = long_unsigned_type_node;
7306 func = builtin_decl_explicit (parity
7307 ? BUILT_IN_PARITYL
7308 : BUILT_IN_POPCOUNTL);
7309 }
7310 else if (argsize <= LONG_LONG_TYPE_SIZE)
7311 {
7312 arg_type = long_long_unsigned_type_node;
7313 func = builtin_decl_explicit (parity
7314 ? BUILT_IN_PARITYLL
7315 : BUILT_IN_POPCOUNTLL);
7316 }
7317 else
7318 {
7319 /* Our argument type is larger than 'long long', which mean none
7320 of the POPCOUNT builtins covers it. We thus call the 'long long'
7321 variant multiple times, and add the results. */
7322 tree utype, arg2, call1, call2;
7323
7324 /* For now, we only cover the case where argsize is twice as large
7325 as 'long long'. */
7326 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7327
7328 func = builtin_decl_explicit (parity
7329 ? BUILT_IN_PARITYLL
7330 : BUILT_IN_POPCOUNTLL);
7331
7332 /* Convert it to an integer, and store into a variable. */
7333 utype = gfc_build_uint_type (argsize);
7334 arg = fold_convert (utype, arg);
7335 arg = gfc_evaluate_now (arg, &se->pre);
7336
7337 /* Call the builtin twice. */
7338 call1 = build_call_expr_loc (input_location, func, 1,
7339 fold_convert (long_long_unsigned_type_node,
7340 arg));
7341
7342 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7343 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7344 call2 = build_call_expr_loc (input_location, func, 1,
7345 fold_convert (long_long_unsigned_type_node,
7346 arg2));
7347
7348 /* Combine the results. */
7349 if (parity)
7350 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
7351 call1, call2);
7352 else
7353 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7354 call1, call2);
7355
7356 return;
7357 }
7358
7359 /* Convert the actual argument twice: first, to the unsigned type of the
7360 same size; then, to the proper argument type for the built-in
7361 function. */
7362 arg = fold_convert (gfc_build_uint_type (argsize), arg);
7363 arg = fold_convert (arg_type, arg);
7364
7365 se->expr = fold_convert (result_type,
7366 build_call_expr_loc (input_location, func, 1, arg));
7367 }
7368
7369
7370 /* Process an intrinsic with unspecified argument-types that has an optional
7371 argument (which could be of type character), e.g. EOSHIFT. For those, we
7372 need to append the string length of the optional argument if it is not
7373 present and the type is really character.
7374 primary specifies the position (starting at 1) of the non-optional argument
7375 specifying the type and optional gives the position of the optional
7376 argument in the arglist. */
7377
7378 static void
conv_generic_with_optional_char_arg(gfc_se * se,gfc_expr * expr,unsigned primary,unsigned optional)7379 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7380 unsigned primary, unsigned optional)
7381 {
7382 gfc_actual_arglist* prim_arg;
7383 gfc_actual_arglist* opt_arg;
7384 unsigned cur_pos;
7385 gfc_actual_arglist* arg;
7386 gfc_symbol* sym;
7387 vec<tree, va_gc> *append_args;
7388
7389 /* Find the two arguments given as position. */
7390 cur_pos = 0;
7391 prim_arg = NULL;
7392 opt_arg = NULL;
7393 for (arg = expr->value.function.actual; arg; arg = arg->next)
7394 {
7395 ++cur_pos;
7396
7397 if (cur_pos == primary)
7398 prim_arg = arg;
7399 if (cur_pos == optional)
7400 opt_arg = arg;
7401
7402 if (cur_pos >= primary && cur_pos >= optional)
7403 break;
7404 }
7405 gcc_assert (prim_arg);
7406 gcc_assert (prim_arg->expr);
7407 gcc_assert (opt_arg);
7408
7409 /* If we do have type CHARACTER and the optional argument is really absent,
7410 append a dummy 0 as string length. */
7411 append_args = NULL;
7412 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7413 {
7414 tree dummy;
7415
7416 dummy = build_int_cst (gfc_charlen_type_node, 0);
7417 vec_alloc (append_args, 1);
7418 append_args->quick_push (dummy);
7419 }
7420
7421 /* Build the call itself. */
7422 gcc_assert (!se->ignore_optional);
7423 sym = gfc_get_symbol_for_expr (expr, false);
7424 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7425 append_args);
7426 gfc_free_symbol (sym);
7427 }
7428
7429 /* The length of a character string. */
7430 static void
gfc_conv_intrinsic_len(gfc_se * se,gfc_expr * expr)7431 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7432 {
7433 tree len;
7434 tree type;
7435 tree decl;
7436 gfc_symbol *sym;
7437 gfc_se argse;
7438 gfc_expr *arg;
7439
7440 gcc_assert (!se->ss);
7441
7442 arg = expr->value.function.actual->expr;
7443
7444 type = gfc_typenode_for_spec (&expr->ts);
7445 switch (arg->expr_type)
7446 {
7447 case EXPR_CONSTANT:
7448 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7449 break;
7450
7451 case EXPR_ARRAY:
7452 /* Obtain the string length from the function used by
7453 trans-array.c(gfc_trans_array_constructor). */
7454 len = NULL_TREE;
7455 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7456 break;
7457
7458 case EXPR_VARIABLE:
7459 if (arg->ref == NULL
7460 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7461 {
7462 /* This doesn't catch all cases.
7463 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7464 and the surrounding thread. */
7465 sym = arg->symtree->n.sym;
7466 decl = gfc_get_symbol_decl (sym);
7467 if (decl == current_function_decl && sym->attr.function
7468 && (sym->result == sym))
7469 decl = gfc_get_fake_result_decl (sym, 0);
7470
7471 len = sym->ts.u.cl->backend_decl;
7472 gcc_assert (len);
7473 break;
7474 }
7475
7476 /* Fall through. */
7477
7478 default:
7479 gfc_init_se (&argse, se);
7480 if (arg->rank == 0)
7481 gfc_conv_expr (&argse, arg);
7482 else
7483 gfc_conv_expr_descriptor (&argse, arg);
7484 gfc_add_block_to_block (&se->pre, &argse.pre);
7485 gfc_add_block_to_block (&se->post, &argse.post);
7486 len = argse.string_length;
7487 break;
7488 }
7489 se->expr = convert (type, len);
7490 }
7491
7492 /* The length of a character string not including trailing blanks. */
7493 static void
gfc_conv_intrinsic_len_trim(gfc_se * se,gfc_expr * expr)7494 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7495 {
7496 int kind = expr->value.function.actual->expr->ts.kind;
7497 tree args[2], type, fndecl;
7498
7499 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7500 type = gfc_typenode_for_spec (&expr->ts);
7501
7502 if (kind == 1)
7503 fndecl = gfor_fndecl_string_len_trim;
7504 else if (kind == 4)
7505 fndecl = gfor_fndecl_string_len_trim_char4;
7506 else
7507 gcc_unreachable ();
7508
7509 se->expr = build_call_expr_loc (input_location,
7510 fndecl, 2, args[0], args[1]);
7511 se->expr = convert (type, se->expr);
7512 }
7513
7514
7515 /* Returns the starting position of a substring within a string. */
7516
7517 static void
gfc_conv_intrinsic_index_scan_verify(gfc_se * se,gfc_expr * expr,tree function)7518 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7519 tree function)
7520 {
7521 tree logical4_type_node = gfc_get_logical_type (4);
7522 tree type;
7523 tree fndecl;
7524 tree *args;
7525 unsigned int num_args;
7526
7527 args = XALLOCAVEC (tree, 5);
7528
7529 /* Get number of arguments; characters count double due to the
7530 string length argument. Kind= is not passed to the library
7531 and thus ignored. */
7532 if (expr->value.function.actual->next->next->expr == NULL)
7533 num_args = 4;
7534 else
7535 num_args = 5;
7536
7537 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7538 type = gfc_typenode_for_spec (&expr->ts);
7539
7540 if (num_args == 4)
7541 args[4] = build_int_cst (logical4_type_node, 0);
7542 else
7543 args[4] = convert (logical4_type_node, args[4]);
7544
7545 fndecl = build_addr (function);
7546 se->expr = build_call_array_loc (input_location,
7547 TREE_TYPE (TREE_TYPE (function)), fndecl,
7548 5, args);
7549 se->expr = convert (type, se->expr);
7550
7551 }
7552
7553 /* The ascii value for a single character. */
7554 static void
gfc_conv_intrinsic_ichar(gfc_se * se,gfc_expr * expr)7555 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7556 {
7557 tree args[3], type, pchartype;
7558 int nargs;
7559
7560 nargs = gfc_intrinsic_argument_list_length (expr);
7561 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7562 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7563 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7564 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7565 type = gfc_typenode_for_spec (&expr->ts);
7566
7567 se->expr = build_fold_indirect_ref_loc (input_location,
7568 args[1]);
7569 se->expr = convert (type, se->expr);
7570 }
7571
7572
7573 /* Intrinsic ISNAN calls __builtin_isnan. */
7574
7575 static void
gfc_conv_intrinsic_isnan(gfc_se * se,gfc_expr * expr)7576 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7577 {
7578 tree arg;
7579
7580 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7581 se->expr = build_call_expr_loc (input_location,
7582 builtin_decl_explicit (BUILT_IN_ISNAN),
7583 1, arg);
7584 STRIP_TYPE_NOPS (se->expr);
7585 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7586 }
7587
7588
7589 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7590 their argument against a constant integer value. */
7591
7592 static void
gfc_conv_has_intvalue(gfc_se * se,gfc_expr * expr,const int value)7593 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7594 {
7595 tree arg;
7596
7597 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7598 se->expr = fold_build2_loc (input_location, EQ_EXPR,
7599 gfc_typenode_for_spec (&expr->ts),
7600 arg, build_int_cst (TREE_TYPE (arg), value));
7601 }
7602
7603
7604
7605 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7606
7607 static void
gfc_conv_intrinsic_merge(gfc_se * se,gfc_expr * expr)7608 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7609 {
7610 tree tsource;
7611 tree fsource;
7612 tree mask;
7613 tree type;
7614 tree len, len2;
7615 tree *args;
7616 unsigned int num_args;
7617
7618 num_args = gfc_intrinsic_argument_list_length (expr);
7619 args = XALLOCAVEC (tree, num_args);
7620
7621 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7622 if (expr->ts.type != BT_CHARACTER)
7623 {
7624 tsource = args[0];
7625 fsource = args[1];
7626 mask = args[2];
7627 }
7628 else
7629 {
7630 /* We do the same as in the non-character case, but the argument
7631 list is different because of the string length arguments. We
7632 also have to set the string length for the result. */
7633 len = args[0];
7634 tsource = args[1];
7635 len2 = args[2];
7636 fsource = args[3];
7637 mask = args[4];
7638
7639 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7640 &se->pre);
7641 se->string_length = len;
7642 }
7643 type = TREE_TYPE (tsource);
7644 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7645 fold_convert (type, fsource));
7646 }
7647
7648
7649 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7650
7651 static void
gfc_conv_intrinsic_merge_bits(gfc_se * se,gfc_expr * expr)7652 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7653 {
7654 tree args[3], mask, type;
7655
7656 gfc_conv_intrinsic_function_args (se, expr, args, 3);
7657 mask = gfc_evaluate_now (args[2], &se->pre);
7658
7659 type = TREE_TYPE (args[0]);
7660 gcc_assert (TREE_TYPE (args[1]) == type);
7661 gcc_assert (TREE_TYPE (mask) == type);
7662
7663 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7664 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7665 fold_build1_loc (input_location, BIT_NOT_EXPR,
7666 type, mask));
7667 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7668 args[0], args[1]);
7669 }
7670
7671
7672 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7673 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7674
7675 static void
gfc_conv_intrinsic_mask(gfc_se * se,gfc_expr * expr,int left)7676 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7677 {
7678 tree arg, allones, type, utype, res, cond, bitsize;
7679 int i;
7680
7681 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7682 arg = gfc_evaluate_now (arg, &se->pre);
7683
7684 type = gfc_get_int_type (expr->ts.kind);
7685 utype = unsigned_type_for (type);
7686
7687 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7688 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7689
7690 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7691 build_int_cst (utype, 0));
7692
7693 if (left)
7694 {
7695 /* Left-justified mask. */
7696 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7697 bitsize, arg);
7698 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7699 fold_convert (utype, res));
7700
7701 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7702 smaller than type width. */
7703 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7704 build_int_cst (TREE_TYPE (arg), 0));
7705 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7706 build_int_cst (utype, 0), res);
7707 }
7708 else
7709 {
7710 /* Right-justified mask. */
7711 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7712 fold_convert (utype, arg));
7713 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7714
7715 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7716 strictly smaller than type width. */
7717 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7718 arg, bitsize);
7719 res = fold_build3_loc (input_location, COND_EXPR, utype,
7720 cond, allones, res);
7721 }
7722
7723 se->expr = fold_convert (type, res);
7724 }
7725
7726
7727 /* FRACTION (s) is translated into:
7728 isfinite (s) ? frexp (s, &dummy_int) : NaN */
7729 static void
gfc_conv_intrinsic_fraction(gfc_se * se,gfc_expr * expr)7730 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7731 {
7732 tree arg, type, tmp, res, frexp, cond;
7733
7734 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7735
7736 type = gfc_typenode_for_spec (&expr->ts);
7737 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7738 arg = gfc_evaluate_now (arg, &se->pre);
7739
7740 cond = build_call_expr_loc (input_location,
7741 builtin_decl_explicit (BUILT_IN_ISFINITE),
7742 1, arg);
7743
7744 tmp = gfc_create_var (integer_type_node, NULL);
7745 res = build_call_expr_loc (input_location, frexp, 2,
7746 fold_convert (type, arg),
7747 gfc_build_addr_expr (NULL_TREE, tmp));
7748 res = fold_convert (type, res);
7749
7750 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7751 cond, res, gfc_build_nan (type, ""));
7752 }
7753
7754
7755 /* NEAREST (s, dir) is translated into
7756 tmp = copysign (HUGE_VAL, dir);
7757 return nextafter (s, tmp);
7758 */
7759 static void
gfc_conv_intrinsic_nearest(gfc_se * se,gfc_expr * expr)7760 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7761 {
7762 tree args[2], type, tmp, nextafter, copysign, huge_val;
7763
7764 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
7765 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
7766
7767 type = gfc_typenode_for_spec (&expr->ts);
7768 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7769
7770 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
7771 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
7772 fold_convert (type, args[1]));
7773 se->expr = build_call_expr_loc (input_location, nextafter, 2,
7774 fold_convert (type, args[0]), tmp);
7775 se->expr = fold_convert (type, se->expr);
7776 }
7777
7778
7779 /* SPACING (s) is translated into
7780 int e;
7781 if (!isfinite (s))
7782 res = NaN;
7783 else if (s == 0)
7784 res = tiny;
7785 else
7786 {
7787 frexp (s, &e);
7788 e = e - prec;
7789 e = MAX_EXPR (e, emin);
7790 res = scalbn (1., e);
7791 }
7792 return res;
7793
7794 where prec is the precision of s, gfc_real_kinds[k].digits,
7795 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7796 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7797
7798 static void
gfc_conv_intrinsic_spacing(gfc_se * se,gfc_expr * expr)7799 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
7800 {
7801 tree arg, type, prec, emin, tiny, res, e;
7802 tree cond, nan, tmp, frexp, scalbn;
7803 int k;
7804 stmtblock_t block;
7805
7806 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7807 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
7808 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
7809 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
7810
7811 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7812 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7813
7814 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7815 arg = gfc_evaluate_now (arg, &se->pre);
7816
7817 type = gfc_typenode_for_spec (&expr->ts);
7818 e = gfc_create_var (integer_type_node, NULL);
7819 res = gfc_create_var (type, NULL);
7820
7821
7822 /* Build the block for s /= 0. */
7823 gfc_start_block (&block);
7824 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7825 gfc_build_addr_expr (NULL_TREE, e));
7826 gfc_add_expr_to_block (&block, tmp);
7827
7828 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
7829 prec);
7830 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
7831 integer_type_node, tmp, emin));
7832
7833 tmp = build_call_expr_loc (input_location, scalbn, 2,
7834 build_real_from_int_cst (type, integer_one_node), e);
7835 gfc_add_modify (&block, res, tmp);
7836
7837 /* Finish by building the IF statement for value zero. */
7838 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7839 build_real_from_int_cst (type, integer_zero_node));
7840 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
7841 gfc_finish_block (&block));
7842
7843 /* And deal with infinities and NaNs. */
7844 cond = build_call_expr_loc (input_location,
7845 builtin_decl_explicit (BUILT_IN_ISFINITE),
7846 1, arg);
7847 nan = gfc_build_nan (type, "");
7848 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
7849
7850 gfc_add_expr_to_block (&se->pre, tmp);
7851 se->expr = res;
7852 }
7853
7854
7855 /* RRSPACING (s) is translated into
7856 int e;
7857 real x;
7858 x = fabs (s);
7859 if (isfinite (x))
7860 {
7861 if (x != 0)
7862 {
7863 frexp (s, &e);
7864 x = scalbn (x, precision - e);
7865 }
7866 }
7867 else
7868 x = NaN;
7869 return x;
7870
7871 where precision is gfc_real_kinds[k].digits. */
7872
7873 static void
gfc_conv_intrinsic_rrspacing(gfc_se * se,gfc_expr * expr)7874 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
7875 {
7876 tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
7877 int prec, k;
7878 stmtblock_t block;
7879
7880 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7881 prec = gfc_real_kinds[k].digits;
7882
7883 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7884 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7885 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
7886
7887 type = gfc_typenode_for_spec (&expr->ts);
7888 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7889 arg = gfc_evaluate_now (arg, &se->pre);
7890
7891 e = gfc_create_var (integer_type_node, NULL);
7892 x = gfc_create_var (type, NULL);
7893 gfc_add_modify (&se->pre, x,
7894 build_call_expr_loc (input_location, fabs, 1, arg));
7895
7896
7897 gfc_start_block (&block);
7898 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7899 gfc_build_addr_expr (NULL_TREE, e));
7900 gfc_add_expr_to_block (&block, tmp);
7901
7902 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
7903 build_int_cst (integer_type_node, prec), e);
7904 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
7905 gfc_add_modify (&block, x, tmp);
7906 stmt = gfc_finish_block (&block);
7907
7908 /* if (x != 0) */
7909 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
7910 build_real_from_int_cst (type, integer_zero_node));
7911 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
7912
7913 /* And deal with infinities and NaNs. */
7914 cond = build_call_expr_loc (input_location,
7915 builtin_decl_explicit (BUILT_IN_ISFINITE),
7916 1, x);
7917 nan = gfc_build_nan (type, "");
7918 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
7919
7920 gfc_add_expr_to_block (&se->pre, tmp);
7921 se->expr = fold_convert (type, x);
7922 }
7923
7924
7925 /* SCALE (s, i) is translated into scalbn (s, i). */
7926 static void
gfc_conv_intrinsic_scale(gfc_se * se,gfc_expr * expr)7927 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
7928 {
7929 tree args[2], type, scalbn;
7930
7931 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7932
7933 type = gfc_typenode_for_spec (&expr->ts);
7934 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7935 se->expr = build_call_expr_loc (input_location, scalbn, 2,
7936 fold_convert (type, args[0]),
7937 fold_convert (integer_type_node, args[1]));
7938 se->expr = fold_convert (type, se->expr);
7939 }
7940
7941
7942 /* SET_EXPONENT (s, i) is translated into
7943 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7944 static void
gfc_conv_intrinsic_set_exponent(gfc_se * se,gfc_expr * expr)7945 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
7946 {
7947 tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
7948
7949 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7950 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7951
7952 type = gfc_typenode_for_spec (&expr->ts);
7953 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7954 args[0] = gfc_evaluate_now (args[0], &se->pre);
7955
7956 tmp = gfc_create_var (integer_type_node, NULL);
7957 tmp = build_call_expr_loc (input_location, frexp, 2,
7958 fold_convert (type, args[0]),
7959 gfc_build_addr_expr (NULL_TREE, tmp));
7960 res = build_call_expr_loc (input_location, scalbn, 2, tmp,
7961 fold_convert (integer_type_node, args[1]));
7962 res = fold_convert (type, res);
7963
7964 /* Call to isfinite */
7965 cond = build_call_expr_loc (input_location,
7966 builtin_decl_explicit (BUILT_IN_ISFINITE),
7967 1, args[0]);
7968 nan = gfc_build_nan (type, "");
7969
7970 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7971 res, nan);
7972 }
7973
7974
7975 static void
gfc_conv_intrinsic_size(gfc_se * se,gfc_expr * expr)7976 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
7977 {
7978 gfc_actual_arglist *actual;
7979 tree arg1;
7980 tree type;
7981 tree fncall0;
7982 tree fncall1;
7983 gfc_se argse;
7984 gfc_expr *e;
7985 gfc_symbol *sym = NULL;
7986
7987 gfc_init_se (&argse, NULL);
7988 actual = expr->value.function.actual;
7989
7990 if (actual->expr->ts.type == BT_CLASS)
7991 gfc_add_class_array_ref (actual->expr);
7992
7993 e = actual->expr;
7994
7995 /* These are emerging from the interface mapping, when a class valued
7996 function appears as the rhs in a realloc on assign statement, where
7997 the size of the result is that of one of the actual arguments. */
7998 if (e->expr_type == EXPR_VARIABLE
7999 && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8000 && e->symtree->n.sym->ts.type == BT_CLASS
8001 && e->ref && e->ref->type == REF_COMPONENT
8002 && strcmp (e->ref->u.c.component->name, "_data") == 0)
8003 sym = e->symtree->n.sym;
8004
8005 if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8006 && e
8007 && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8008 {
8009 symbol_attribute attr;
8010 char *msg;
8011 tree temp;
8012 tree cond;
8013
8014 if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8015 {
8016 attr = CLASS_DATA (e->symtree->n.sym)->attr;
8017 attr.pointer = attr.class_pointer;
8018 }
8019 else
8020 attr = gfc_expr_attr (e);
8021
8022 if (attr.allocatable)
8023 msg = xasprintf ("Allocatable argument '%s' is not allocated",
8024 e->symtree->n.sym->name);
8025 else if (attr.pointer)
8026 msg = xasprintf ("Pointer argument '%s' is not associated",
8027 e->symtree->n.sym->name);
8028 else
8029 goto end_arg_check;
8030
8031 if (sym)
8032 {
8033 temp = gfc_class_data_get (sym->backend_decl);
8034 temp = gfc_conv_descriptor_data_get (temp);
8035 }
8036 else
8037 {
8038 argse.descriptor_only = 1;
8039 gfc_conv_expr_descriptor (&argse, actual->expr);
8040 temp = gfc_conv_descriptor_data_get (argse.expr);
8041 }
8042
8043 cond = fold_build2_loc (input_location, EQ_EXPR,
8044 logical_type_node, temp,
8045 fold_convert (TREE_TYPE (temp),
8046 null_pointer_node));
8047 gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8048
8049 free (msg);
8050 }
8051 end_arg_check:
8052
8053 argse.data_not_needed = 1;
8054 if (gfc_is_class_array_function (e))
8055 {
8056 /* For functions that return a class array conv_expr_descriptor is not
8057 able to get the descriptor right. Therefore this special case. */
8058 gfc_conv_expr_reference (&argse, e);
8059 argse.expr = gfc_build_addr_expr (NULL_TREE,
8060 gfc_class_data_get (argse.expr));
8061 }
8062 else if (sym && sym->backend_decl)
8063 {
8064 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8065 argse.expr = sym->backend_decl;
8066 argse.expr = gfc_build_addr_expr (NULL_TREE,
8067 gfc_class_data_get (argse.expr));
8068 }
8069 else
8070 {
8071 argse.want_pointer = 1;
8072 gfc_conv_expr_descriptor (&argse, actual->expr);
8073 }
8074 gfc_add_block_to_block (&se->pre, &argse.pre);
8075 gfc_add_block_to_block (&se->post, &argse.post);
8076 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
8077
8078 /* Build the call to size0. */
8079 fncall0 = build_call_expr_loc (input_location,
8080 gfor_fndecl_size0, 1, arg1);
8081
8082 actual = actual->next;
8083
8084 if (actual->expr)
8085 {
8086 gfc_init_se (&argse, NULL);
8087 gfc_conv_expr_type (&argse, actual->expr,
8088 gfc_array_index_type);
8089 gfc_add_block_to_block (&se->pre, &argse.pre);
8090
8091 /* Unusually, for an intrinsic, size does not exclude
8092 an optional arg2, so we must test for it. */
8093 if (actual->expr->expr_type == EXPR_VARIABLE
8094 && actual->expr->symtree->n.sym->attr.dummy
8095 && actual->expr->symtree->n.sym->attr.optional)
8096 {
8097 tree tmp;
8098 /* Build the call to size1. */
8099 fncall1 = build_call_expr_loc (input_location,
8100 gfor_fndecl_size1, 2,
8101 arg1, argse.expr);
8102
8103 gfc_init_se (&argse, NULL);
8104 argse.want_pointer = 1;
8105 argse.data_not_needed = 1;
8106 gfc_conv_expr (&argse, actual->expr);
8107 gfc_add_block_to_block (&se->pre, &argse.pre);
8108 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8109 argse.expr, null_pointer_node);
8110 tmp = gfc_evaluate_now (tmp, &se->pre);
8111 se->expr = fold_build3_loc (input_location, COND_EXPR,
8112 pvoid_type_node, tmp, fncall1, fncall0);
8113 }
8114 else
8115 {
8116 se->expr = NULL_TREE;
8117 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
8118 gfc_array_index_type,
8119 argse.expr, gfc_index_one_node);
8120 }
8121 }
8122 else if (expr->value.function.actual->expr->rank == 1)
8123 {
8124 argse.expr = gfc_index_zero_node;
8125 se->expr = NULL_TREE;
8126 }
8127 else
8128 se->expr = fncall0;
8129
8130 if (se->expr == NULL_TREE)
8131 {
8132 tree ubound, lbound;
8133
8134 arg1 = build_fold_indirect_ref_loc (input_location,
8135 arg1);
8136 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
8137 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
8138 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
8139 gfc_array_index_type, ubound, lbound);
8140 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
8141 gfc_array_index_type,
8142 se->expr, gfc_index_one_node);
8143 se->expr = fold_build2_loc (input_location, MAX_EXPR,
8144 gfc_array_index_type, se->expr,
8145 gfc_index_zero_node);
8146 }
8147
8148 type = gfc_typenode_for_spec (&expr->ts);
8149 se->expr = convert (type, se->expr);
8150 }
8151
8152
8153 /* Helper function to compute the size of a character variable,
8154 excluding the terminating null characters. The result has
8155 gfc_array_index_type type. */
8156
8157 tree
size_of_string_in_bytes(int kind,tree string_length)8158 size_of_string_in_bytes (int kind, tree string_length)
8159 {
8160 tree bytesize;
8161 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8162
8163 bytesize = build_int_cst (gfc_array_index_type,
8164 gfc_character_kinds[i].bit_size / 8);
8165
8166 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8167 bytesize,
8168 fold_convert (gfc_array_index_type, string_length));
8169 }
8170
8171
8172 static void
gfc_conv_intrinsic_sizeof(gfc_se * se,gfc_expr * expr)8173 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8174 {
8175 gfc_expr *arg;
8176 gfc_se argse;
8177 tree source_bytes;
8178 tree tmp;
8179 tree lower;
8180 tree upper;
8181 tree byte_size;
8182 tree field;
8183 int n;
8184
8185 gfc_init_se (&argse, NULL);
8186 arg = expr->value.function.actual->expr;
8187
8188 if (arg->rank || arg->ts.type == BT_ASSUMED)
8189 gfc_conv_expr_descriptor (&argse, arg);
8190 else
8191 gfc_conv_expr_reference (&argse, arg);
8192
8193 if (arg->ts.type == BT_ASSUMED)
8194 {
8195 /* This only works if an array descriptor has been passed; thus, extract
8196 the size from the descriptor. */
8197 gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8198 == TYPE_PRECISION (size_type_node));
8199 tmp = arg->symtree->n.sym->backend_decl;
8200 tmp = DECL_LANG_SPECIFIC (tmp)
8201 && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8202 ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8203 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8204 tmp = build_fold_indirect_ref_loc (input_location, tmp);
8205
8206 tmp = gfc_conv_descriptor_dtype (tmp);
8207 field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8208 GFC_DTYPE_ELEM_LEN);
8209 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8210 tmp, field, NULL_TREE);
8211
8212 byte_size = fold_convert (gfc_array_index_type, tmp);
8213 }
8214 else if (arg->ts.type == BT_CLASS)
8215 {
8216 /* Conv_expr_descriptor returns a component_ref to _data component of the
8217 class object. The class object may be a non-pointer object, e.g.
8218 located on the stack, or a memory location pointed to, e.g. a
8219 parameter, i.e., an indirect_ref. */
8220 if (arg->rank < 0
8221 || (arg->rank > 0 && !VAR_P (argse.expr)
8222 && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
8223 && GFC_DECL_CLASS (TREE_OPERAND (
8224 TREE_OPERAND (argse.expr, 0), 0)))
8225 || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
8226 byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8227 else if (arg->rank > 0
8228 || (arg->rank == 0
8229 && arg->ref && arg->ref->type == REF_COMPONENT))
8230 /* The scalarizer added an additional temp. To get the class' vptr
8231 one has to look at the original backend_decl. */
8232 byte_size = gfc_class_vtab_size_get (
8233 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8234 else
8235 byte_size = gfc_class_vtab_size_get (argse.expr);
8236 }
8237 else
8238 {
8239 if (arg->ts.type == BT_CHARACTER)
8240 byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8241 else
8242 {
8243 if (arg->rank == 0)
8244 byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8245 argse.expr));
8246 else
8247 byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8248 byte_size = fold_convert (gfc_array_index_type,
8249 size_in_bytes (byte_size));
8250 }
8251 }
8252
8253 if (arg->rank == 0)
8254 se->expr = byte_size;
8255 else
8256 {
8257 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8258 gfc_add_modify (&argse.pre, source_bytes, byte_size);
8259
8260 if (arg->rank == -1)
8261 {
8262 tree cond, loop_var, exit_label;
8263 stmtblock_t body;
8264
8265 tmp = fold_convert (gfc_array_index_type,
8266 gfc_conv_descriptor_rank (argse.expr));
8267 loop_var = gfc_create_var (gfc_array_index_type, "i");
8268 gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8269 exit_label = gfc_build_label_decl (NULL_TREE);
8270
8271 /* Create loop:
8272 for (;;)
8273 {
8274 if (i >= rank)
8275 goto exit;
8276 source_bytes = source_bytes * array.dim[i].extent;
8277 i = i + 1;
8278 }
8279 exit: */
8280 gfc_start_block (&body);
8281 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8282 loop_var, tmp);
8283 tmp = build1_v (GOTO_EXPR, exit_label);
8284 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8285 cond, tmp, build_empty_stmt (input_location));
8286 gfc_add_expr_to_block (&body, tmp);
8287
8288 lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8289 upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8290 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8291 tmp = fold_build2_loc (input_location, MULT_EXPR,
8292 gfc_array_index_type, tmp, source_bytes);
8293 gfc_add_modify (&body, source_bytes, tmp);
8294
8295 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8296 gfc_array_index_type, loop_var,
8297 gfc_index_one_node);
8298 gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8299
8300 tmp = gfc_finish_block (&body);
8301
8302 tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8303 tmp);
8304 gfc_add_expr_to_block (&argse.pre, tmp);
8305
8306 tmp = build1_v (LABEL_EXPR, exit_label);
8307 gfc_add_expr_to_block (&argse.pre, tmp);
8308 }
8309 else
8310 {
8311 /* Obtain the size of the array in bytes. */
8312 for (n = 0; n < arg->rank; n++)
8313 {
8314 tree idx;
8315 idx = gfc_rank_cst[n];
8316 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8317 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8318 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8319 tmp = fold_build2_loc (input_location, MULT_EXPR,
8320 gfc_array_index_type, tmp, source_bytes);
8321 gfc_add_modify (&argse.pre, source_bytes, tmp);
8322 }
8323 }
8324 se->expr = source_bytes;
8325 }
8326
8327 gfc_add_block_to_block (&se->pre, &argse.pre);
8328 }
8329
8330
8331 static void
gfc_conv_intrinsic_storage_size(gfc_se * se,gfc_expr * expr)8332 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8333 {
8334 gfc_expr *arg;
8335 gfc_se argse;
8336 tree type, result_type, tmp;
8337
8338 arg = expr->value.function.actual->expr;
8339
8340 gfc_init_se (&argse, NULL);
8341 result_type = gfc_get_int_type (expr->ts.kind);
8342
8343 if (arg->rank == 0)
8344 {
8345 if (arg->ts.type == BT_CLASS)
8346 {
8347 gfc_add_vptr_component (arg);
8348 gfc_add_size_component (arg);
8349 gfc_conv_expr (&argse, arg);
8350 tmp = fold_convert (result_type, argse.expr);
8351 goto done;
8352 }
8353
8354 gfc_conv_expr_reference (&argse, arg);
8355 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8356 argse.expr));
8357 }
8358 else
8359 {
8360 argse.want_pointer = 0;
8361 gfc_conv_expr_descriptor (&argse, arg);
8362 if (arg->ts.type == BT_CLASS)
8363 {
8364 if (arg->rank > 0)
8365 tmp = gfc_class_vtab_size_get (
8366 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8367 else
8368 tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8369 tmp = fold_convert (result_type, tmp);
8370 goto done;
8371 }
8372 type = gfc_get_element_type (TREE_TYPE (argse.expr));
8373 }
8374
8375 /* Obtain the argument's word length. */
8376 if (arg->ts.type == BT_CHARACTER)
8377 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8378 else
8379 tmp = size_in_bytes (type);
8380 tmp = fold_convert (result_type, tmp);
8381
8382 done:
8383 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8384 build_int_cst (result_type, BITS_PER_UNIT));
8385 gfc_add_block_to_block (&se->pre, &argse.pre);
8386 }
8387
8388
8389 /* Intrinsic string comparison functions. */
8390
8391 static void
gfc_conv_intrinsic_strcmp(gfc_se * se,gfc_expr * expr,enum tree_code op)8392 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8393 {
8394 tree args[4];
8395
8396 gfc_conv_intrinsic_function_args (se, expr, args, 4);
8397
8398 se->expr
8399 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8400 expr->value.function.actual->expr->ts.kind,
8401 op);
8402 se->expr = fold_build2_loc (input_location, op,
8403 gfc_typenode_for_spec (&expr->ts), se->expr,
8404 build_int_cst (TREE_TYPE (se->expr), 0));
8405 }
8406
8407 /* Generate a call to the adjustl/adjustr library function. */
8408 static void
gfc_conv_intrinsic_adjust(gfc_se * se,gfc_expr * expr,tree fndecl)8409 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8410 {
8411 tree args[3];
8412 tree len;
8413 tree type;
8414 tree var;
8415 tree tmp;
8416
8417 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8418 len = args[1];
8419
8420 type = TREE_TYPE (args[2]);
8421 var = gfc_conv_string_tmp (se, type, len);
8422 args[0] = var;
8423
8424 tmp = build_call_expr_loc (input_location,
8425 fndecl, 3, args[0], args[1], args[2]);
8426 gfc_add_expr_to_block (&se->pre, tmp);
8427 se->expr = var;
8428 se->string_length = len;
8429 }
8430
8431
8432 /* Generate code for the TRANSFER intrinsic:
8433 For scalar results:
8434 DEST = TRANSFER (SOURCE, MOLD)
8435 where:
8436 typeof<DEST> = typeof<MOLD>
8437 and:
8438 MOLD is scalar.
8439
8440 For array results:
8441 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8442 where:
8443 typeof<DEST> = typeof<MOLD>
8444 and:
8445 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8446 sizeof (DEST(0) * SIZE). */
8447 static void
gfc_conv_intrinsic_transfer(gfc_se * se,gfc_expr * expr)8448 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8449 {
8450 tree tmp;
8451 tree tmpdecl;
8452 tree ptr;
8453 tree extent;
8454 tree source;
8455 tree source_type;
8456 tree source_bytes;
8457 tree mold_type;
8458 tree dest_word_len;
8459 tree size_words;
8460 tree size_bytes;
8461 tree upper;
8462 tree lower;
8463 tree stmt;
8464 tree class_ref = NULL_TREE;
8465 gfc_actual_arglist *arg;
8466 gfc_se argse;
8467 gfc_array_info *info;
8468 stmtblock_t block;
8469 int n;
8470 bool scalar_mold;
8471 gfc_expr *source_expr, *mold_expr, *class_expr;
8472
8473 info = NULL;
8474 if (se->loop)
8475 info = &se->ss->info->data.array;
8476
8477 /* Convert SOURCE. The output from this stage is:-
8478 source_bytes = length of the source in bytes
8479 source = pointer to the source data. */
8480 arg = expr->value.function.actual;
8481 source_expr = arg->expr;
8482
8483 /* Ensure double transfer through LOGICAL preserves all
8484 the needed bits. */
8485 if (arg->expr->expr_type == EXPR_FUNCTION
8486 && arg->expr->value.function.esym == NULL
8487 && arg->expr->value.function.isym != NULL
8488 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8489 && arg->expr->ts.type == BT_LOGICAL
8490 && expr->ts.type != arg->expr->ts.type)
8491 arg->expr->value.function.name = "__transfer_in_transfer";
8492
8493 gfc_init_se (&argse, NULL);
8494
8495 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8496
8497 /* Obtain the pointer to source and the length of source in bytes. */
8498 if (arg->expr->rank == 0)
8499 {
8500 gfc_conv_expr_reference (&argse, arg->expr);
8501 if (arg->expr->ts.type == BT_CLASS)
8502 {
8503 tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8504 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8505 source = gfc_class_data_get (tmp);
8506 else
8507 {
8508 /* Array elements are evaluated as a reference to the data.
8509 To obtain the vptr for the element size, the argument
8510 expression must be stripped to the class reference and
8511 re-evaluated. The pre and post blocks are not needed. */
8512 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8513 source = argse.expr;
8514 class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8515 gfc_init_se (&argse, NULL);
8516 gfc_conv_expr (&argse, class_expr);
8517 class_ref = argse.expr;
8518 }
8519 }
8520 else
8521 source = argse.expr;
8522
8523 /* Obtain the source word length. */
8524 switch (arg->expr->ts.type)
8525 {
8526 case BT_CHARACTER:
8527 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8528 argse.string_length);
8529 break;
8530 case BT_CLASS:
8531 if (class_ref != NULL_TREE)
8532 tmp = gfc_class_vtab_size_get (class_ref);
8533 else
8534 tmp = gfc_class_vtab_size_get (argse.expr);
8535 break;
8536 default:
8537 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8538 source));
8539 tmp = fold_convert (gfc_array_index_type,
8540 size_in_bytes (source_type));
8541 break;
8542 }
8543 }
8544 else
8545 {
8546 argse.want_pointer = 0;
8547 gfc_conv_expr_descriptor (&argse, arg->expr);
8548 source = gfc_conv_descriptor_data_get (argse.expr);
8549 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8550
8551 /* Repack the source if not simply contiguous. */
8552 if (!gfc_is_simply_contiguous (arg->expr, false, true))
8553 {
8554 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8555
8556 if (warn_array_temporaries)
8557 gfc_warning (OPT_Warray_temporaries,
8558 "Creating array temporary at %L", &expr->where);
8559
8560 source = build_call_expr_loc (input_location,
8561 gfor_fndecl_in_pack, 1, tmp);
8562 source = gfc_evaluate_now (source, &argse.pre);
8563
8564 /* Free the temporary. */
8565 gfc_start_block (&block);
8566 tmp = gfc_call_free (source);
8567 gfc_add_expr_to_block (&block, tmp);
8568 stmt = gfc_finish_block (&block);
8569
8570 /* Clean up if it was repacked. */
8571 gfc_init_block (&block);
8572 tmp = gfc_conv_array_data (argse.expr);
8573 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8574 source, tmp);
8575 tmp = build3_v (COND_EXPR, tmp, stmt,
8576 build_empty_stmt (input_location));
8577 gfc_add_expr_to_block (&block, tmp);
8578 gfc_add_block_to_block (&block, &se->post);
8579 gfc_init_block (&se->post);
8580 gfc_add_block_to_block (&se->post, &block);
8581 }
8582
8583 /* Obtain the source word length. */
8584 if (arg->expr->ts.type == BT_CHARACTER)
8585 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8586 argse.string_length);
8587 else
8588 tmp = fold_convert (gfc_array_index_type,
8589 size_in_bytes (source_type));
8590
8591 /* Obtain the size of the array in bytes. */
8592 extent = gfc_create_var (gfc_array_index_type, NULL);
8593 for (n = 0; n < arg->expr->rank; n++)
8594 {
8595 tree idx;
8596 idx = gfc_rank_cst[n];
8597 gfc_add_modify (&argse.pre, source_bytes, tmp);
8598 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8599 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8600 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8601 gfc_array_index_type, upper, lower);
8602 gfc_add_modify (&argse.pre, extent, tmp);
8603 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8604 gfc_array_index_type, extent,
8605 gfc_index_one_node);
8606 tmp = fold_build2_loc (input_location, MULT_EXPR,
8607 gfc_array_index_type, tmp, source_bytes);
8608 }
8609 }
8610
8611 gfc_add_modify (&argse.pre, source_bytes, tmp);
8612 gfc_add_block_to_block (&se->pre, &argse.pre);
8613 gfc_add_block_to_block (&se->post, &argse.post);
8614
8615 /* Now convert MOLD. The outputs are:
8616 mold_type = the TREE type of MOLD
8617 dest_word_len = destination word length in bytes. */
8618 arg = arg->next;
8619 mold_expr = arg->expr;
8620
8621 gfc_init_se (&argse, NULL);
8622
8623 scalar_mold = arg->expr->rank == 0;
8624
8625 if (arg->expr->rank == 0)
8626 {
8627 gfc_conv_expr_reference (&argse, arg->expr);
8628 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8629 argse.expr));
8630 }
8631 else
8632 {
8633 gfc_init_se (&argse, NULL);
8634 argse.want_pointer = 0;
8635 gfc_conv_expr_descriptor (&argse, arg->expr);
8636 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8637 }
8638
8639 gfc_add_block_to_block (&se->pre, &argse.pre);
8640 gfc_add_block_to_block (&se->post, &argse.post);
8641
8642 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8643 {
8644 /* If this TRANSFER is nested in another TRANSFER, use a type
8645 that preserves all bits. */
8646 if (arg->expr->ts.type == BT_LOGICAL)
8647 mold_type = gfc_get_int_type (arg->expr->ts.kind);
8648 }
8649
8650 /* Obtain the destination word length. */
8651 switch (arg->expr->ts.type)
8652 {
8653 case BT_CHARACTER:
8654 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
8655 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
8656 break;
8657 case BT_CLASS:
8658 tmp = gfc_class_vtab_size_get (argse.expr);
8659 break;
8660 default:
8661 tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8662 break;
8663 }
8664 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8665 gfc_add_modify (&se->pre, dest_word_len, tmp);
8666
8667 /* Finally convert SIZE, if it is present. */
8668 arg = arg->next;
8669 size_words = gfc_create_var (gfc_array_index_type, NULL);
8670
8671 if (arg->expr)
8672 {
8673 gfc_init_se (&argse, NULL);
8674 gfc_conv_expr_reference (&argse, arg->expr);
8675 tmp = convert (gfc_array_index_type,
8676 build_fold_indirect_ref_loc (input_location,
8677 argse.expr));
8678 gfc_add_block_to_block (&se->pre, &argse.pre);
8679 gfc_add_block_to_block (&se->post, &argse.post);
8680 }
8681 else
8682 tmp = NULL_TREE;
8683
8684 /* Separate array and scalar results. */
8685 if (scalar_mold && tmp == NULL_TREE)
8686 goto scalar_transfer;
8687
8688 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8689 if (tmp != NULL_TREE)
8690 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8691 tmp, dest_word_len);
8692 else
8693 tmp = source_bytes;
8694
8695 gfc_add_modify (&se->pre, size_bytes, tmp);
8696 gfc_add_modify (&se->pre, size_words,
8697 fold_build2_loc (input_location, CEIL_DIV_EXPR,
8698 gfc_array_index_type,
8699 size_bytes, dest_word_len));
8700
8701 /* Evaluate the bounds of the result. If the loop range exists, we have
8702 to check if it is too large. If so, we modify loop->to be consistent
8703 with min(size, size(source)). Otherwise, size is made consistent with
8704 the loop range, so that the right number of bytes is transferred.*/
8705 n = se->loop->order[0];
8706 if (se->loop->to[n] != NULL_TREE)
8707 {
8708 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8709 se->loop->to[n], se->loop->from[n]);
8710 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8711 tmp, gfc_index_one_node);
8712 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8713 tmp, size_words);
8714 gfc_add_modify (&se->pre, size_words, tmp);
8715 gfc_add_modify (&se->pre, size_bytes,
8716 fold_build2_loc (input_location, MULT_EXPR,
8717 gfc_array_index_type,
8718 size_words, dest_word_len));
8719 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8720 size_words, se->loop->from[n]);
8721 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8722 upper, gfc_index_one_node);
8723 }
8724 else
8725 {
8726 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8727 size_words, gfc_index_one_node);
8728 se->loop->from[n] = gfc_index_zero_node;
8729 }
8730
8731 se->loop->to[n] = upper;
8732
8733 /* Build a destination descriptor, using the pointer, source, as the
8734 data field. */
8735 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
8736 NULL_TREE, false, true, false, &expr->where);
8737
8738 /* Cast the pointer to the result. */
8739 tmp = gfc_conv_descriptor_data_get (info->descriptor);
8740 tmp = fold_convert (pvoid_type_node, tmp);
8741
8742 /* Use memcpy to do the transfer. */
8743 tmp
8744 = build_call_expr_loc (input_location,
8745 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
8746 fold_convert (pvoid_type_node, source),
8747 fold_convert (size_type_node,
8748 fold_build2_loc (input_location,
8749 MIN_EXPR,
8750 gfc_array_index_type,
8751 size_bytes,
8752 source_bytes)));
8753 gfc_add_expr_to_block (&se->pre, tmp);
8754
8755 se->expr = info->descriptor;
8756 if (expr->ts.type == BT_CHARACTER)
8757 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
8758
8759 return;
8760
8761 /* Deal with scalar results. */
8762 scalar_transfer:
8763 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8764 dest_word_len, source_bytes);
8765 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8766 extent, gfc_index_zero_node);
8767
8768 if (expr->ts.type == BT_CHARACTER)
8769 {
8770 tree direct, indirect, free;
8771
8772 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
8773 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
8774 "transfer");
8775
8776 /* If source is longer than the destination, use a pointer to
8777 the source directly. */
8778 gfc_init_block (&block);
8779 gfc_add_modify (&block, tmpdecl, ptr);
8780 direct = gfc_finish_block (&block);
8781
8782 /* Otherwise, allocate a string with the length of the destination
8783 and copy the source into it. */
8784 gfc_init_block (&block);
8785 tmp = gfc_get_pchar_type (expr->ts.kind);
8786 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
8787 gfc_add_modify (&block, tmpdecl,
8788 fold_convert (TREE_TYPE (ptr), tmp));
8789 tmp = build_call_expr_loc (input_location,
8790 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
8791 fold_convert (pvoid_type_node, tmpdecl),
8792 fold_convert (pvoid_type_node, ptr),
8793 fold_convert (size_type_node, extent));
8794 gfc_add_expr_to_block (&block, tmp);
8795 indirect = gfc_finish_block (&block);
8796
8797 /* Wrap it up with the condition. */
8798 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
8799 dest_word_len, source_bytes);
8800 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
8801 gfc_add_expr_to_block (&se->pre, tmp);
8802
8803 /* Free the temporary string, if necessary. */
8804 free = gfc_call_free (tmpdecl);
8805 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8806 dest_word_len, source_bytes);
8807 tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
8808 gfc_add_expr_to_block (&se->post, tmp);
8809
8810 se->expr = tmpdecl;
8811 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
8812 }
8813 else
8814 {
8815 tmpdecl = gfc_create_var (mold_type, "transfer");
8816
8817 ptr = convert (build_pointer_type (mold_type), source);
8818
8819 /* For CLASS results, allocate the needed memory first. */
8820 if (mold_expr->ts.type == BT_CLASS)
8821 {
8822 tree cdata;
8823 cdata = gfc_class_data_get (tmpdecl);
8824 tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
8825 gfc_add_modify (&se->pre, cdata, tmp);
8826 }
8827
8828 /* Use memcpy to do the transfer. */
8829 if (mold_expr->ts.type == BT_CLASS)
8830 tmp = gfc_class_data_get (tmpdecl);
8831 else
8832 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
8833
8834 tmp = build_call_expr_loc (input_location,
8835 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
8836 fold_convert (pvoid_type_node, tmp),
8837 fold_convert (pvoid_type_node, ptr),
8838 fold_convert (size_type_node, extent));
8839 gfc_add_expr_to_block (&se->pre, tmp);
8840
8841 /* For CLASS results, set the _vptr. */
8842 if (mold_expr->ts.type == BT_CLASS)
8843 {
8844 tree vptr;
8845 gfc_symbol *vtab;
8846 vptr = gfc_class_vptr_get (tmpdecl);
8847 vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
8848 gcc_assert (vtab);
8849 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
8850 gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
8851 }
8852
8853 se->expr = tmpdecl;
8854 }
8855 }
8856
8857
8858 /* Generate a call to caf_is_present. */
8859
8860 static tree
trans_caf_is_present(gfc_se * se,gfc_expr * expr)8861 trans_caf_is_present (gfc_se *se, gfc_expr *expr)
8862 {
8863 tree caf_reference, caf_decl, token, image_index;
8864
8865 /* Compile the reference chain. */
8866 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
8867 gcc_assert (caf_reference != NULL_TREE);
8868
8869 caf_decl = gfc_get_tree_for_caf_expr (expr);
8870 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
8871 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
8872 image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl);
8873 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
8874 expr);
8875
8876 return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
8877 3, token, image_index, caf_reference);
8878 }
8879
8880
8881 /* Test whether this ref-chain refs this image only. */
8882
8883 static bool
caf_this_image_ref(gfc_ref * ref)8884 caf_this_image_ref (gfc_ref *ref)
8885 {
8886 for ( ; ref; ref = ref->next)
8887 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
8888 return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
8889
8890 return false;
8891 }
8892
8893
8894 /* Generate code for the ALLOCATED intrinsic.
8895 Generate inline code that directly check the address of the argument. */
8896
8897 static void
gfc_conv_allocated(gfc_se * se,gfc_expr * expr)8898 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
8899 {
8900 gfc_actual_arglist *arg1;
8901 gfc_se arg1se;
8902 tree tmp;
8903 symbol_attribute caf_attr;
8904
8905 gfc_init_se (&arg1se, NULL);
8906 arg1 = expr->value.function.actual;
8907
8908 if (arg1->expr->ts.type == BT_CLASS)
8909 {
8910 /* Make sure that class array expressions have both a _data
8911 component reference and an array reference.... */
8912 if (CLASS_DATA (arg1->expr)->attr.dimension)
8913 gfc_add_class_array_ref (arg1->expr);
8914 /* .... whilst scalars only need the _data component. */
8915 else
8916 gfc_add_data_component (arg1->expr);
8917 }
8918
8919 /* When arg1 references an allocatable component in a coarray, then call
8920 the caf-library function caf_is_present (). */
8921 if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION
8922 && arg1->expr->value.function.isym
8923 && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
8924 caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr);
8925 else
8926 gfc_clear_attr (&caf_attr);
8927 if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension
8928 && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref))
8929 tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr);
8930 else
8931 {
8932 if (arg1->expr->rank == 0)
8933 {
8934 /* Allocatable scalar. */
8935 arg1se.want_pointer = 1;
8936 gfc_conv_expr (&arg1se, arg1->expr);
8937 tmp = arg1se.expr;
8938 }
8939 else
8940 {
8941 /* Allocatable array. */
8942 arg1se.descriptor_only = 1;
8943 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
8944 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
8945 }
8946
8947 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
8948 fold_convert (TREE_TYPE (tmp), null_pointer_node));
8949 }
8950
8951 /* Components of pointer array references sometimes come back with a pre block. */
8952 if (arg1se.pre.head)
8953 gfc_add_block_to_block (&se->pre, &arg1se.pre);
8954
8955 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
8956 }
8957
8958
8959 /* Generate code for the ASSOCIATED intrinsic.
8960 If both POINTER and TARGET are arrays, generate a call to library function
8961 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8962 In other cases, generate inline code that directly compare the address of
8963 POINTER with the address of TARGET. */
8964
8965 static void
gfc_conv_associated(gfc_se * se,gfc_expr * expr)8966 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
8967 {
8968 gfc_actual_arglist *arg1;
8969 gfc_actual_arglist *arg2;
8970 gfc_se arg1se;
8971 gfc_se arg2se;
8972 tree tmp2;
8973 tree tmp;
8974 tree nonzero_arraylen;
8975 gfc_ss *ss;
8976 bool scalar;
8977
8978 gfc_init_se (&arg1se, NULL);
8979 gfc_init_se (&arg2se, NULL);
8980 arg1 = expr->value.function.actual;
8981 arg2 = arg1->next;
8982
8983 /* Check whether the expression is a scalar or not; we cannot use
8984 arg1->expr->rank as it can be nonzero for proc pointers. */
8985 ss = gfc_walk_expr (arg1->expr);
8986 scalar = ss == gfc_ss_terminator;
8987 if (!scalar)
8988 gfc_free_ss_chain (ss);
8989
8990 if (!arg2->expr)
8991 {
8992 /* No optional target. */
8993 if (scalar)
8994 {
8995 /* A pointer to a scalar. */
8996 arg1se.want_pointer = 1;
8997 gfc_conv_expr (&arg1se, arg1->expr);
8998 if (arg1->expr->symtree->n.sym->attr.proc_pointer
8999 && arg1->expr->symtree->n.sym->attr.dummy)
9000 arg1se.expr = build_fold_indirect_ref_loc (input_location,
9001 arg1se.expr);
9002 if (arg1->expr->ts.type == BT_CLASS)
9003 {
9004 tmp2 = gfc_class_data_get (arg1se.expr);
9005 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9006 tmp2 = gfc_conv_descriptor_data_get (tmp2);
9007 }
9008 else
9009 tmp2 = arg1se.expr;
9010 }
9011 else
9012 {
9013 /* A pointer to an array. */
9014 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9015 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9016 }
9017 gfc_add_block_to_block (&se->pre, &arg1se.pre);
9018 gfc_add_block_to_block (&se->post, &arg1se.post);
9019 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9020 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9021 se->expr = tmp;
9022 }
9023 else
9024 {
9025 /* An optional target. */
9026 if (arg2->expr->ts.type == BT_CLASS
9027 && arg2->expr->expr_type != EXPR_FUNCTION)
9028 gfc_add_data_component (arg2->expr);
9029
9030 if (scalar)
9031 {
9032 /* A pointer to a scalar. */
9033 arg1se.want_pointer = 1;
9034 gfc_conv_expr (&arg1se, arg1->expr);
9035 if (arg1->expr->symtree->n.sym->attr.proc_pointer
9036 && arg1->expr->symtree->n.sym->attr.dummy)
9037 arg1se.expr = build_fold_indirect_ref_loc (input_location,
9038 arg1se.expr);
9039 if (arg1->expr->ts.type == BT_CLASS)
9040 arg1se.expr = gfc_class_data_get (arg1se.expr);
9041
9042 arg2se.want_pointer = 1;
9043 gfc_conv_expr (&arg2se, arg2->expr);
9044 if (arg2->expr->symtree->n.sym->attr.proc_pointer
9045 && arg2->expr->symtree->n.sym->attr.dummy)
9046 arg2se.expr = build_fold_indirect_ref_loc (input_location,
9047 arg2se.expr);
9048 if (arg2->expr->ts.type == BT_CLASS)
9049 {
9050 arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9051 arg2se.expr = gfc_class_data_get (arg2se.expr);
9052 }
9053 gfc_add_block_to_block (&se->pre, &arg1se.pre);
9054 gfc_add_block_to_block (&se->post, &arg1se.post);
9055 gfc_add_block_to_block (&se->pre, &arg2se.pre);
9056 gfc_add_block_to_block (&se->post, &arg2se.post);
9057 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9058 arg1se.expr, arg2se.expr);
9059 tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9060 arg1se.expr, null_pointer_node);
9061 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9062 logical_type_node, tmp, tmp2);
9063 }
9064 else
9065 {
9066 /* An array pointer of zero length is not associated if target is
9067 present. */
9068 arg1se.descriptor_only = 1;
9069 gfc_conv_expr_lhs (&arg1se, arg1->expr);
9070 if (arg1->expr->rank == -1)
9071 {
9072 tmp = gfc_conv_descriptor_rank (arg1se.expr);
9073 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9074 TREE_TYPE (tmp), tmp, gfc_index_one_node);
9075 }
9076 else
9077 tmp = gfc_rank_cst[arg1->expr->rank - 1];
9078 tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9079 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9080 logical_type_node, tmp,
9081 build_int_cst (TREE_TYPE (tmp), 0));
9082
9083 /* A pointer to an array, call library function _gfor_associated. */
9084 arg1se.want_pointer = 1;
9085 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9086 gfc_add_block_to_block (&se->pre, &arg1se.pre);
9087 gfc_add_block_to_block (&se->post, &arg1se.post);
9088
9089 arg2se.want_pointer = 1;
9090 gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9091 gfc_add_block_to_block (&se->pre, &arg2se.pre);
9092 gfc_add_block_to_block (&se->post, &arg2se.post);
9093 se->expr = build_call_expr_loc (input_location,
9094 gfor_fndecl_associated, 2,
9095 arg1se.expr, arg2se.expr);
9096 se->expr = convert (logical_type_node, se->expr);
9097 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9098 logical_type_node, se->expr,
9099 nonzero_arraylen);
9100 }
9101
9102 /* If target is present zero character length pointers cannot
9103 be associated. */
9104 if (arg1->expr->ts.type == BT_CHARACTER)
9105 {
9106 tmp = arg1se.string_length;
9107 tmp = fold_build2_loc (input_location, NE_EXPR,
9108 logical_type_node, tmp,
9109 build_zero_cst (TREE_TYPE (tmp)));
9110 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9111 logical_type_node, se->expr, tmp);
9112 }
9113 }
9114
9115 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9116 }
9117
9118
9119 /* Generate code for the SAME_TYPE_AS intrinsic.
9120 Generate inline code that directly checks the vindices. */
9121
9122 static void
gfc_conv_same_type_as(gfc_se * se,gfc_expr * expr)9123 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9124 {
9125 gfc_expr *a, *b;
9126 gfc_se se1, se2;
9127 tree tmp;
9128 tree conda = NULL_TREE, condb = NULL_TREE;
9129
9130 gfc_init_se (&se1, NULL);
9131 gfc_init_se (&se2, NULL);
9132
9133 a = expr->value.function.actual->expr;
9134 b = expr->value.function.actual->next->expr;
9135
9136 if (UNLIMITED_POLY (a))
9137 {
9138 tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
9139 conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9140 tmp, build_int_cst (TREE_TYPE (tmp), 0));
9141 }
9142
9143 if (UNLIMITED_POLY (b))
9144 {
9145 tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
9146 condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9147 tmp, build_int_cst (TREE_TYPE (tmp), 0));
9148 }
9149
9150 if (a->ts.type == BT_CLASS)
9151 {
9152 gfc_add_vptr_component (a);
9153 gfc_add_hash_component (a);
9154 }
9155 else if (a->ts.type == BT_DERIVED)
9156 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9157 a->ts.u.derived->hash_value);
9158
9159 if (b->ts.type == BT_CLASS)
9160 {
9161 gfc_add_vptr_component (b);
9162 gfc_add_hash_component (b);
9163 }
9164 else if (b->ts.type == BT_DERIVED)
9165 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9166 b->ts.u.derived->hash_value);
9167
9168 gfc_conv_expr (&se1, a);
9169 gfc_conv_expr (&se2, b);
9170
9171 tmp = fold_build2_loc (input_location, EQ_EXPR,
9172 logical_type_node, se1.expr,
9173 fold_convert (TREE_TYPE (se1.expr), se2.expr));
9174
9175 if (conda)
9176 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9177 logical_type_node, conda, tmp);
9178
9179 if (condb)
9180 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9181 logical_type_node, condb, tmp);
9182
9183 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9184 }
9185
9186
9187 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9188
9189 static void
gfc_conv_intrinsic_sc_kind(gfc_se * se,gfc_expr * expr)9190 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9191 {
9192 tree args[2];
9193
9194 gfc_conv_intrinsic_function_args (se, expr, args, 2);
9195 se->expr = build_call_expr_loc (input_location,
9196 gfor_fndecl_sc_kind, 2, args[0], args[1]);
9197 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9198 }
9199
9200
9201 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9202
9203 static void
gfc_conv_intrinsic_si_kind(gfc_se * se,gfc_expr * expr)9204 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9205 {
9206 tree arg, type;
9207
9208 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9209
9210 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9211 type = gfc_get_int_type (4);
9212 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9213
9214 /* Convert it to the required type. */
9215 type = gfc_typenode_for_spec (&expr->ts);
9216 se->expr = build_call_expr_loc (input_location,
9217 gfor_fndecl_si_kind, 1, arg);
9218 se->expr = fold_convert (type, se->expr);
9219 }
9220
9221
9222 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9223
9224 static void
gfc_conv_intrinsic_sr_kind(gfc_se * se,gfc_expr * expr)9225 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9226 {
9227 gfc_actual_arglist *actual;
9228 tree type;
9229 gfc_se argse;
9230 vec<tree, va_gc> *args = NULL;
9231
9232 for (actual = expr->value.function.actual; actual; actual = actual->next)
9233 {
9234 gfc_init_se (&argse, se);
9235
9236 /* Pass a NULL pointer for an absent arg. */
9237 if (actual->expr == NULL)
9238 argse.expr = null_pointer_node;
9239 else
9240 {
9241 gfc_typespec ts;
9242 gfc_clear_ts (&ts);
9243
9244 if (actual->expr->ts.kind != gfc_c_int_kind)
9245 {
9246 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9247 ts.type = BT_INTEGER;
9248 ts.kind = gfc_c_int_kind;
9249 gfc_convert_type (actual->expr, &ts, 2);
9250 }
9251 gfc_conv_expr_reference (&argse, actual->expr);
9252 }
9253
9254 gfc_add_block_to_block (&se->pre, &argse.pre);
9255 gfc_add_block_to_block (&se->post, &argse.post);
9256 vec_safe_push (args, argse.expr);
9257 }
9258
9259 /* Convert it to the required type. */
9260 type = gfc_typenode_for_spec (&expr->ts);
9261 se->expr = build_call_expr_loc_vec (input_location,
9262 gfor_fndecl_sr_kind, args);
9263 se->expr = fold_convert (type, se->expr);
9264 }
9265
9266
9267 /* Generate code for TRIM (A) intrinsic function. */
9268
9269 static void
gfc_conv_intrinsic_trim(gfc_se * se,gfc_expr * expr)9270 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9271 {
9272 tree var;
9273 tree len;
9274 tree addr;
9275 tree tmp;
9276 tree cond;
9277 tree fndecl;
9278 tree function;
9279 tree *args;
9280 unsigned int num_args;
9281
9282 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9283 args = XALLOCAVEC (tree, num_args);
9284
9285 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9286 addr = gfc_build_addr_expr (ppvoid_type_node, var);
9287 len = gfc_create_var (gfc_charlen_type_node, "len");
9288
9289 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9290 args[0] = gfc_build_addr_expr (NULL_TREE, len);
9291 args[1] = addr;
9292
9293 if (expr->ts.kind == 1)
9294 function = gfor_fndecl_string_trim;
9295 else if (expr->ts.kind == 4)
9296 function = gfor_fndecl_string_trim_char4;
9297 else
9298 gcc_unreachable ();
9299
9300 fndecl = build_addr (function);
9301 tmp = build_call_array_loc (input_location,
9302 TREE_TYPE (TREE_TYPE (function)), fndecl,
9303 num_args, args);
9304 gfc_add_expr_to_block (&se->pre, tmp);
9305
9306 /* Free the temporary afterwards, if necessary. */
9307 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9308 len, build_int_cst (TREE_TYPE (len), 0));
9309 tmp = gfc_call_free (var);
9310 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9311 gfc_add_expr_to_block (&se->post, tmp);
9312
9313 se->expr = var;
9314 se->string_length = len;
9315 }
9316
9317
9318 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9319
9320 static void
gfc_conv_intrinsic_repeat(gfc_se * se,gfc_expr * expr)9321 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9322 {
9323 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9324 tree type, cond, tmp, count, exit_label, n, max, largest;
9325 tree size;
9326 stmtblock_t block, body;
9327 int i;
9328
9329 /* We store in charsize the size of a character. */
9330 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9331 size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9332
9333 /* Get the arguments. */
9334 gfc_conv_intrinsic_function_args (se, expr, args, 3);
9335 slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9336 src = args[1];
9337 ncopies = gfc_evaluate_now (args[2], &se->pre);
9338 ncopies_type = TREE_TYPE (ncopies);
9339
9340 /* Check that NCOPIES is not negative. */
9341 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9342 build_int_cst (ncopies_type, 0));
9343 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9344 "Argument NCOPIES of REPEAT intrinsic is negative "
9345 "(its value is %ld)",
9346 fold_convert (long_integer_type_node, ncopies));
9347
9348 /* If the source length is zero, any non negative value of NCOPIES
9349 is valid, and nothing happens. */
9350 n = gfc_create_var (ncopies_type, "ncopies");
9351 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9352 size_zero_node);
9353 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9354 build_int_cst (ncopies_type, 0), ncopies);
9355 gfc_add_modify (&se->pre, n, tmp);
9356 ncopies = n;
9357
9358 /* Check that ncopies is not too large: ncopies should be less than
9359 (or equal to) MAX / slen, where MAX is the maximal integer of
9360 the gfc_charlen_type_node type. If slen == 0, we need a special
9361 case to avoid the division by zero. */
9362 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9363 fold_convert (sizetype,
9364 TYPE_MAX_VALUE (gfc_charlen_type_node)),
9365 slen);
9366 largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9367 ? sizetype : ncopies_type;
9368 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9369 fold_convert (largest, ncopies),
9370 fold_convert (largest, max));
9371 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9372 size_zero_node);
9373 cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9374 logical_false_node, cond);
9375 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9376 "Argument NCOPIES of REPEAT intrinsic is too large");
9377
9378 /* Compute the destination length. */
9379 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9380 fold_convert (gfc_charlen_type_node, slen),
9381 fold_convert (gfc_charlen_type_node, ncopies));
9382 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9383 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9384
9385 /* Generate the code to do the repeat operation:
9386 for (i = 0; i < ncopies; i++)
9387 memmove (dest + (i * slen * size), src, slen*size); */
9388 gfc_start_block (&block);
9389 count = gfc_create_var (sizetype, "count");
9390 gfc_add_modify (&block, count, size_zero_node);
9391 exit_label = gfc_build_label_decl (NULL_TREE);
9392
9393 /* Start the loop body. */
9394 gfc_start_block (&body);
9395
9396 /* Exit the loop if count >= ncopies. */
9397 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9398 fold_convert (sizetype, ncopies));
9399 tmp = build1_v (GOTO_EXPR, exit_label);
9400 TREE_USED (exit_label) = 1;
9401 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9402 build_empty_stmt (input_location));
9403 gfc_add_expr_to_block (&body, tmp);
9404
9405 /* Call memmove (dest + (i*slen*size), src, slen*size). */
9406 tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9407 count);
9408 tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9409 size);
9410 tmp = fold_build_pointer_plus_loc (input_location,
9411 fold_convert (pvoid_type_node, dest), tmp);
9412 tmp = build_call_expr_loc (input_location,
9413 builtin_decl_explicit (BUILT_IN_MEMMOVE),
9414 3, tmp, src,
9415 fold_build2_loc (input_location, MULT_EXPR,
9416 size_type_node, slen, size));
9417 gfc_add_expr_to_block (&body, tmp);
9418
9419 /* Increment count. */
9420 tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9421 count, size_one_node);
9422 gfc_add_modify (&body, count, tmp);
9423
9424 /* Build the loop. */
9425 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9426 gfc_add_expr_to_block (&block, tmp);
9427
9428 /* Add the exit label. */
9429 tmp = build1_v (LABEL_EXPR, exit_label);
9430 gfc_add_expr_to_block (&block, tmp);
9431
9432 /* Finish the block. */
9433 tmp = gfc_finish_block (&block);
9434 gfc_add_expr_to_block (&se->pre, tmp);
9435
9436 /* Set the result value. */
9437 se->expr = dest;
9438 se->string_length = dlen;
9439 }
9440
9441
9442 /* Generate code for the IARGC intrinsic. */
9443
9444 static void
gfc_conv_intrinsic_iargc(gfc_se * se,gfc_expr * expr)9445 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9446 {
9447 tree tmp;
9448 tree fndecl;
9449 tree type;
9450
9451 /* Call the library function. This always returns an INTEGER(4). */
9452 fndecl = gfor_fndecl_iargc;
9453 tmp = build_call_expr_loc (input_location,
9454 fndecl, 0);
9455
9456 /* Convert it to the required type. */
9457 type = gfc_typenode_for_spec (&expr->ts);
9458 tmp = fold_convert (type, tmp);
9459
9460 se->expr = tmp;
9461 }
9462
9463
9464 /* Generate code for the KILL intrinsic. */
9465
9466 static void
conv_intrinsic_kill(gfc_se * se,gfc_expr * expr)9467 conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9468 {
9469 tree *args;
9470 tree int4_type_node = gfc_get_int_type (4);
9471 tree pid;
9472 tree sig;
9473 tree tmp;
9474 unsigned int num_args;
9475
9476 num_args = gfc_intrinsic_argument_list_length (expr);
9477 args = XALLOCAVEC (tree, num_args);
9478 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9479
9480 /* Convert PID to a INTEGER(4) entity. */
9481 pid = convert (int4_type_node, args[0]);
9482
9483 /* Convert SIG to a INTEGER(4) entity. */
9484 sig = convert (int4_type_node, args[1]);
9485
9486 tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9487
9488 se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9489 }
9490
9491
9492 static tree
conv_intrinsic_kill_sub(gfc_code * code)9493 conv_intrinsic_kill_sub (gfc_code *code)
9494 {
9495 stmtblock_t block;
9496 gfc_se se, se_stat;
9497 tree int4_type_node = gfc_get_int_type (4);
9498 tree pid;
9499 tree sig;
9500 tree statp;
9501 tree tmp;
9502
9503 /* Make the function call. */
9504 gfc_init_block (&block);
9505 gfc_init_se (&se, NULL);
9506
9507 /* Convert PID to a INTEGER(4) entity. */
9508 gfc_conv_expr (&se, code->ext.actual->expr);
9509 gfc_add_block_to_block (&block, &se.pre);
9510 pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9511 gfc_add_block_to_block (&block, &se.post);
9512
9513 /* Convert SIG to a INTEGER(4) entity. */
9514 gfc_conv_expr (&se, code->ext.actual->next->expr);
9515 gfc_add_block_to_block (&block, &se.pre);
9516 sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9517 gfc_add_block_to_block (&block, &se.post);
9518
9519 /* Deal with an optional STATUS. */
9520 if (code->ext.actual->next->next->expr)
9521 {
9522 gfc_init_se (&se_stat, NULL);
9523 gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9524 statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9525 }
9526 else
9527 statp = NULL_TREE;
9528
9529 tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9530 statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9531
9532 gfc_add_expr_to_block (&block, tmp);
9533
9534 if (statp && statp != se_stat.expr)
9535 gfc_add_modify (&block, se_stat.expr,
9536 fold_convert (TREE_TYPE (se_stat.expr), statp));
9537
9538 return gfc_finish_block (&block);
9539 }
9540
9541
9542
9543 /* The loc intrinsic returns the address of its argument as
9544 gfc_index_integer_kind integer. */
9545
9546 static void
gfc_conv_intrinsic_loc(gfc_se * se,gfc_expr * expr)9547 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9548 {
9549 tree temp_var;
9550 gfc_expr *arg_expr;
9551
9552 gcc_assert (!se->ss);
9553
9554 arg_expr = expr->value.function.actual->expr;
9555 if (arg_expr->rank == 0)
9556 {
9557 if (arg_expr->ts.type == BT_CLASS)
9558 gfc_add_data_component (arg_expr);
9559 gfc_conv_expr_reference (se, arg_expr);
9560 }
9561 else
9562 gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9563 se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9564
9565 /* Create a temporary variable for loc return value. Without this,
9566 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
9567 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9568 gfc_add_modify (&se->pre, temp_var, se->expr);
9569 se->expr = temp_var;
9570 }
9571
9572
9573 /* The following routine generates code for the intrinsic
9574 functions from the ISO_C_BINDING module:
9575 * C_LOC
9576 * C_FUNLOC
9577 * C_ASSOCIATED */
9578
9579 static void
conv_isocbinding_function(gfc_se * se,gfc_expr * expr)9580 conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9581 {
9582 gfc_actual_arglist *arg = expr->value.function.actual;
9583
9584 if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9585 {
9586 if (arg->expr->rank == 0)
9587 gfc_conv_expr_reference (se, arg->expr);
9588 else if (gfc_is_simply_contiguous (arg->expr, false, false))
9589 gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9590 else
9591 {
9592 gfc_conv_expr_descriptor (se, arg->expr);
9593 se->expr = gfc_conv_descriptor_data_get (se->expr);
9594 }
9595
9596 /* TODO -- the following two lines shouldn't be necessary, but if
9597 they're removed, a bug is exposed later in the code path.
9598 This workaround was thus introduced, but will have to be
9599 removed; please see PR 35150 for details about the issue. */
9600 se->expr = convert (pvoid_type_node, se->expr);
9601 se->expr = gfc_evaluate_now (se->expr, &se->pre);
9602 }
9603 else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9604 gfc_conv_expr_reference (se, arg->expr);
9605 else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9606 {
9607 gfc_se arg1se;
9608 gfc_se arg2se;
9609
9610 /* Build the addr_expr for the first argument. The argument is
9611 already an *address* so we don't need to set want_pointer in
9612 the gfc_se. */
9613 gfc_init_se (&arg1se, NULL);
9614 gfc_conv_expr (&arg1se, arg->expr);
9615 gfc_add_block_to_block (&se->pre, &arg1se.pre);
9616 gfc_add_block_to_block (&se->post, &arg1se.post);
9617
9618 /* See if we were given two arguments. */
9619 if (arg->next->expr == NULL)
9620 /* Only given one arg so generate a null and do a
9621 not-equal comparison against the first arg. */
9622 se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9623 arg1se.expr,
9624 fold_convert (TREE_TYPE (arg1se.expr),
9625 null_pointer_node));
9626 else
9627 {
9628 tree eq_expr;
9629 tree not_null_expr;
9630
9631 /* Given two arguments so build the arg2se from second arg. */
9632 gfc_init_se (&arg2se, NULL);
9633 gfc_conv_expr (&arg2se, arg->next->expr);
9634 gfc_add_block_to_block (&se->pre, &arg2se.pre);
9635 gfc_add_block_to_block (&se->post, &arg2se.post);
9636
9637 /* Generate test to compare that the two args are equal. */
9638 eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9639 arg1se.expr, arg2se.expr);
9640 /* Generate test to ensure that the first arg is not null. */
9641 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9642 logical_type_node,
9643 arg1se.expr, null_pointer_node);
9644
9645 /* Finally, the generated test must check that both arg1 is not
9646 NULL and that it is equal to the second arg. */
9647 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9648 logical_type_node,
9649 not_null_expr, eq_expr);
9650 }
9651 }
9652 else
9653 gcc_unreachable ();
9654 }
9655
9656
9657 /* The following routine generates code for the intrinsic
9658 subroutines from the ISO_C_BINDING module:
9659 * C_F_POINTER
9660 * C_F_PROCPOINTER. */
9661
9662 static tree
conv_isocbinding_subroutine(gfc_code * code)9663 conv_isocbinding_subroutine (gfc_code *code)
9664 {
9665 gfc_se se;
9666 gfc_se cptrse;
9667 gfc_se fptrse;
9668 gfc_se shapese;
9669 gfc_ss *shape_ss;
9670 tree desc, dim, tmp, stride, offset;
9671 stmtblock_t body, block;
9672 gfc_loopinfo loop;
9673 gfc_actual_arglist *arg = code->ext.actual;
9674
9675 gfc_init_se (&se, NULL);
9676 gfc_init_se (&cptrse, NULL);
9677 gfc_conv_expr (&cptrse, arg->expr);
9678 gfc_add_block_to_block (&se.pre, &cptrse.pre);
9679 gfc_add_block_to_block (&se.post, &cptrse.post);
9680
9681 gfc_init_se (&fptrse, NULL);
9682 if (arg->next->expr->rank == 0)
9683 {
9684 fptrse.want_pointer = 1;
9685 gfc_conv_expr (&fptrse, arg->next->expr);
9686 gfc_add_block_to_block (&se.pre, &fptrse.pre);
9687 gfc_add_block_to_block (&se.post, &fptrse.post);
9688 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
9689 && arg->next->expr->symtree->n.sym->attr.dummy)
9690 fptrse.expr = build_fold_indirect_ref_loc (input_location,
9691 fptrse.expr);
9692 se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
9693 TREE_TYPE (fptrse.expr),
9694 fptrse.expr,
9695 fold_convert (TREE_TYPE (fptrse.expr),
9696 cptrse.expr));
9697 gfc_add_expr_to_block (&se.pre, se.expr);
9698 gfc_add_block_to_block (&se.pre, &se.post);
9699 return gfc_finish_block (&se.pre);
9700 }
9701
9702 gfc_start_block (&block);
9703
9704 /* Get the descriptor of the Fortran pointer. */
9705 fptrse.descriptor_only = 1;
9706 gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
9707 gfc_add_block_to_block (&block, &fptrse.pre);
9708 desc = fptrse.expr;
9709
9710 /* Set the span field. */
9711 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9712 tmp = fold_convert (gfc_array_index_type, tmp);
9713 gfc_conv_descriptor_span_set (&block, desc, tmp);
9714
9715 /* Set data value, dtype, and offset. */
9716 tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
9717 gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
9718 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
9719 gfc_get_dtype (TREE_TYPE (desc)));
9720
9721 /* Start scalarization of the bounds, using the shape argument. */
9722
9723 shape_ss = gfc_walk_expr (arg->next->next->expr);
9724 gcc_assert (shape_ss != gfc_ss_terminator);
9725 gfc_init_se (&shapese, NULL);
9726
9727 gfc_init_loopinfo (&loop);
9728 gfc_add_ss_to_loop (&loop, shape_ss);
9729 gfc_conv_ss_startstride (&loop);
9730 gfc_conv_loop_setup (&loop, &arg->next->expr->where);
9731 gfc_mark_ss_chain_used (shape_ss, 1);
9732
9733 gfc_copy_loopinfo_to_se (&shapese, &loop);
9734 shapese.ss = shape_ss;
9735
9736 stride = gfc_create_var (gfc_array_index_type, "stride");
9737 offset = gfc_create_var (gfc_array_index_type, "offset");
9738 gfc_add_modify (&block, stride, gfc_index_one_node);
9739 gfc_add_modify (&block, offset, gfc_index_zero_node);
9740
9741 /* Loop body. */
9742 gfc_start_scalarized_body (&loop, &body);
9743
9744 dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9745 loop.loopvar[0], loop.from[0]);
9746
9747 /* Set bounds and stride. */
9748 gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
9749 gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
9750
9751 gfc_conv_expr (&shapese, arg->next->next->expr);
9752 gfc_add_block_to_block (&body, &shapese.pre);
9753 gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
9754 gfc_add_block_to_block (&body, &shapese.post);
9755
9756 /* Calculate offset. */
9757 gfc_add_modify (&body, offset,
9758 fold_build2_loc (input_location, PLUS_EXPR,
9759 gfc_array_index_type, offset, stride));
9760 /* Update stride. */
9761 gfc_add_modify (&body, stride,
9762 fold_build2_loc (input_location, MULT_EXPR,
9763 gfc_array_index_type, stride,
9764 fold_convert (gfc_array_index_type,
9765 shapese.expr)));
9766 /* Finish scalarization loop. */
9767 gfc_trans_scalarizing_loops (&loop, &body);
9768 gfc_add_block_to_block (&block, &loop.pre);
9769 gfc_add_block_to_block (&block, &loop.post);
9770 gfc_add_block_to_block (&block, &fptrse.post);
9771 gfc_cleanup_loop (&loop);
9772
9773 gfc_add_modify (&block, offset,
9774 fold_build1_loc (input_location, NEGATE_EXPR,
9775 gfc_array_index_type, offset));
9776 gfc_conv_descriptor_offset_set (&block, desc, offset);
9777
9778 gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
9779 gfc_add_block_to_block (&se.pre, &se.post);
9780 return gfc_finish_block (&se.pre);
9781 }
9782
9783
9784 /* Save and restore floating-point state. */
9785
9786 tree
gfc_save_fp_state(stmtblock_t * block)9787 gfc_save_fp_state (stmtblock_t *block)
9788 {
9789 tree type, fpstate, tmp;
9790
9791 type = build_array_type (char_type_node,
9792 build_range_type (size_type_node, size_zero_node,
9793 size_int (GFC_FPE_STATE_BUFFER_SIZE)));
9794 fpstate = gfc_create_var (type, "fpstate");
9795 fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
9796
9797 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
9798 1, fpstate);
9799 gfc_add_expr_to_block (block, tmp);
9800
9801 return fpstate;
9802 }
9803
9804
9805 void
gfc_restore_fp_state(stmtblock_t * block,tree fpstate)9806 gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
9807 {
9808 tree tmp;
9809
9810 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
9811 1, fpstate);
9812 gfc_add_expr_to_block (block, tmp);
9813 }
9814
9815
9816 /* Generate code for arguments of IEEE functions. */
9817
9818 static void
conv_ieee_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)9819 conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
9820 int nargs)
9821 {
9822 gfc_actual_arglist *actual;
9823 gfc_expr *e;
9824 gfc_se argse;
9825 int arg;
9826
9827 actual = expr->value.function.actual;
9828 for (arg = 0; arg < nargs; arg++, actual = actual->next)
9829 {
9830 gcc_assert (actual);
9831 e = actual->expr;
9832
9833 gfc_init_se (&argse, se);
9834 gfc_conv_expr_val (&argse, e);
9835
9836 gfc_add_block_to_block (&se->pre, &argse.pre);
9837 gfc_add_block_to_block (&se->post, &argse.post);
9838 argarray[arg] = argse.expr;
9839 }
9840 }
9841
9842
9843 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
9844 and IEEE_UNORDERED, which translate directly to GCC type-generic
9845 built-ins. */
9846
9847 static void
conv_intrinsic_ieee_builtin(gfc_se * se,gfc_expr * expr,enum built_in_function code,int nargs)9848 conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
9849 enum built_in_function code, int nargs)
9850 {
9851 tree args[2];
9852 gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0]));
9853
9854 conv_ieee_function_args (se, expr, args, nargs);
9855 se->expr = build_call_expr_loc_array (input_location,
9856 builtin_decl_explicit (code),
9857 nargs, args);
9858 STRIP_TYPE_NOPS (se->expr);
9859 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9860 }
9861
9862
9863 /* Generate code for IEEE_IS_NORMAL intrinsic:
9864 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9865
9866 static void
conv_intrinsic_ieee_is_normal(gfc_se * se,gfc_expr * expr)9867 conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
9868 {
9869 tree arg, isnormal, iszero;
9870
9871 /* Convert arg, evaluate it only once. */
9872 conv_ieee_function_args (se, expr, &arg, 1);
9873 arg = gfc_evaluate_now (arg, &se->pre);
9874
9875 isnormal = build_call_expr_loc (input_location,
9876 builtin_decl_explicit (BUILT_IN_ISNORMAL),
9877 1, arg);
9878 iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
9879 build_real_from_int_cst (TREE_TYPE (arg),
9880 integer_zero_node));
9881 se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9882 logical_type_node, isnormal, iszero);
9883 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9884 }
9885
9886
9887 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9888 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9889
9890 static void
conv_intrinsic_ieee_is_negative(gfc_se * se,gfc_expr * expr)9891 conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
9892 {
9893 tree arg, signbit, isnan;
9894
9895 /* Convert arg, evaluate it only once. */
9896 conv_ieee_function_args (se, expr, &arg, 1);
9897 arg = gfc_evaluate_now (arg, &se->pre);
9898
9899 isnan = build_call_expr_loc (input_location,
9900 builtin_decl_explicit (BUILT_IN_ISNAN),
9901 1, arg);
9902 STRIP_TYPE_NOPS (isnan);
9903
9904 signbit = build_call_expr_loc (input_location,
9905 builtin_decl_explicit (BUILT_IN_SIGNBIT),
9906 1, arg);
9907 signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9908 signbit, integer_zero_node);
9909
9910 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9911 logical_type_node, signbit,
9912 fold_build1_loc (input_location, TRUTH_NOT_EXPR,
9913 TREE_TYPE(isnan), isnan));
9914
9915 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9916 }
9917
9918
9919 /* Generate code for IEEE_LOGB and IEEE_RINT. */
9920
9921 static void
conv_intrinsic_ieee_logb_rint(gfc_se * se,gfc_expr * expr,enum built_in_function code)9922 conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
9923 enum built_in_function code)
9924 {
9925 tree arg, decl, call, fpstate;
9926 int argprec;
9927
9928 conv_ieee_function_args (se, expr, &arg, 1);
9929 argprec = TYPE_PRECISION (TREE_TYPE (arg));
9930 decl = builtin_decl_for_precision (code, argprec);
9931
9932 /* Save floating-point state. */
9933 fpstate = gfc_save_fp_state (&se->pre);
9934
9935 /* Make the function call. */
9936 call = build_call_expr_loc (input_location, decl, 1, arg);
9937 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
9938
9939 /* Restore floating-point state. */
9940 gfc_restore_fp_state (&se->post, fpstate);
9941 }
9942
9943
9944 /* Generate code for IEEE_REM. */
9945
9946 static void
conv_intrinsic_ieee_rem(gfc_se * se,gfc_expr * expr)9947 conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
9948 {
9949 tree args[2], decl, call, fpstate;
9950 int argprec;
9951
9952 conv_ieee_function_args (se, expr, args, 2);
9953
9954 /* If arguments have unequal size, convert them to the larger. */
9955 if (TYPE_PRECISION (TREE_TYPE (args[0]))
9956 > TYPE_PRECISION (TREE_TYPE (args[1])))
9957 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9958 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
9959 > TYPE_PRECISION (TREE_TYPE (args[0])))
9960 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
9961
9962 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9963 decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
9964
9965 /* Save floating-point state. */
9966 fpstate = gfc_save_fp_state (&se->pre);
9967
9968 /* Make the function call. */
9969 call = build_call_expr_loc_array (input_location, decl, 2, args);
9970 se->expr = fold_convert (TREE_TYPE (args[0]), call);
9971
9972 /* Restore floating-point state. */
9973 gfc_restore_fp_state (&se->post, fpstate);
9974 }
9975
9976
9977 /* Generate code for IEEE_NEXT_AFTER. */
9978
9979 static void
conv_intrinsic_ieee_next_after(gfc_se * se,gfc_expr * expr)9980 conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
9981 {
9982 tree args[2], decl, call, fpstate;
9983 int argprec;
9984
9985 conv_ieee_function_args (se, expr, args, 2);
9986
9987 /* Result has the characteristics of first argument. */
9988 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9989 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9990 decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
9991
9992 /* Save floating-point state. */
9993 fpstate = gfc_save_fp_state (&se->pre);
9994
9995 /* Make the function call. */
9996 call = build_call_expr_loc_array (input_location, decl, 2, args);
9997 se->expr = fold_convert (TREE_TYPE (args[0]), call);
9998
9999 /* Restore floating-point state. */
10000 gfc_restore_fp_state (&se->post, fpstate);
10001 }
10002
10003
10004 /* Generate code for IEEE_SCALB. */
10005
10006 static void
conv_intrinsic_ieee_scalb(gfc_se * se,gfc_expr * expr)10007 conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10008 {
10009 tree args[2], decl, call, huge, type;
10010 int argprec, n;
10011
10012 conv_ieee_function_args (se, expr, args, 2);
10013
10014 /* Result has the characteristics of first argument. */
10015 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10016 decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10017
10018 if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10019 {
10020 /* We need to fold the integer into the range of a C int. */
10021 args[1] = gfc_evaluate_now (args[1], &se->pre);
10022 type = TREE_TYPE (args[1]);
10023
10024 n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10025 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10026 gfc_c_int_kind);
10027 huge = fold_convert (type, huge);
10028 args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10029 huge);
10030 args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10031 fold_build1_loc (input_location, NEGATE_EXPR,
10032 type, huge));
10033 }
10034
10035 args[1] = fold_convert (integer_type_node, args[1]);
10036
10037 /* Make the function call. */
10038 call = build_call_expr_loc_array (input_location, decl, 2, args);
10039 se->expr = fold_convert (TREE_TYPE (args[0]), call);
10040 }
10041
10042
10043 /* Generate code for IEEE_COPY_SIGN. */
10044
10045 static void
conv_intrinsic_ieee_copy_sign(gfc_se * se,gfc_expr * expr)10046 conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10047 {
10048 tree args[2], decl, sign;
10049 int argprec;
10050
10051 conv_ieee_function_args (se, expr, args, 2);
10052
10053 /* Get the sign of the second argument. */
10054 sign = build_call_expr_loc (input_location,
10055 builtin_decl_explicit (BUILT_IN_SIGNBIT),
10056 1, args[1]);
10057 sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10058 sign, integer_zero_node);
10059
10060 /* Create a value of one, with the right sign. */
10061 sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10062 sign,
10063 fold_build1_loc (input_location, NEGATE_EXPR,
10064 integer_type_node,
10065 integer_one_node),
10066 integer_one_node);
10067 args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10068
10069 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10070 decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10071
10072 se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10073 }
10074
10075
10076 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10077 module. */
10078
10079 bool
gfc_conv_ieee_arithmetic_function(gfc_se * se,gfc_expr * expr)10080 gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
10081 {
10082 const char *name = expr->value.function.name;
10083
10084 if (gfc_str_startswith (name, "_gfortran_ieee_is_nan"))
10085 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
10086 else if (gfc_str_startswith (name, "_gfortran_ieee_is_finite"))
10087 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
10088 else if (gfc_str_startswith (name, "_gfortran_ieee_unordered"))
10089 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
10090 else if (gfc_str_startswith (name, "_gfortran_ieee_is_normal"))
10091 conv_intrinsic_ieee_is_normal (se, expr);
10092 else if (gfc_str_startswith (name, "_gfortran_ieee_is_negative"))
10093 conv_intrinsic_ieee_is_negative (se, expr);
10094 else if (gfc_str_startswith (name, "_gfortran_ieee_copy_sign"))
10095 conv_intrinsic_ieee_copy_sign (se, expr);
10096 else if (gfc_str_startswith (name, "_gfortran_ieee_scalb"))
10097 conv_intrinsic_ieee_scalb (se, expr);
10098 else if (gfc_str_startswith (name, "_gfortran_ieee_next_after"))
10099 conv_intrinsic_ieee_next_after (se, expr);
10100 else if (gfc_str_startswith (name, "_gfortran_ieee_rem"))
10101 conv_intrinsic_ieee_rem (se, expr);
10102 else if (gfc_str_startswith (name, "_gfortran_ieee_logb"))
10103 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
10104 else if (gfc_str_startswith (name, "_gfortran_ieee_rint"))
10105 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
10106 else
10107 /* It is not among the functions we translate directly. We return
10108 false, so a library function call is emitted. */
10109 return false;
10110
10111 return true;
10112 }
10113
10114
10115 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
10116
10117 static void
gfc_conv_intrinsic_malloc(gfc_se * se,gfc_expr * expr)10118 gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
10119 {
10120 tree arg, res, restype;
10121
10122 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
10123 arg = fold_convert (size_type_node, arg);
10124 res = build_call_expr_loc (input_location,
10125 builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
10126 restype = gfc_typenode_for_spec (&expr->ts);
10127 se->expr = fold_convert (restype, res);
10128 }
10129
10130
10131 /* Generate code for an intrinsic function. Some map directly to library
10132 calls, others get special handling. In some cases the name of the function
10133 used depends on the type specifiers. */
10134
10135 void
gfc_conv_intrinsic_function(gfc_se * se,gfc_expr * expr)10136 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
10137 {
10138 const char *name;
10139 int lib, kind;
10140 tree fndecl;
10141
10142 name = &expr->value.function.name[2];
10143
10144 if (expr->rank > 0)
10145 {
10146 lib = gfc_is_intrinsic_libcall (expr);
10147 if (lib != 0)
10148 {
10149 if (lib == 1)
10150 se->ignore_optional = 1;
10151
10152 switch (expr->value.function.isym->id)
10153 {
10154 case GFC_ISYM_EOSHIFT:
10155 case GFC_ISYM_PACK:
10156 case GFC_ISYM_RESHAPE:
10157 /* For all of those the first argument specifies the type and the
10158 third is optional. */
10159 conv_generic_with_optional_char_arg (se, expr, 1, 3);
10160 break;
10161
10162 case GFC_ISYM_FINDLOC:
10163 gfc_conv_intrinsic_findloc (se, expr);
10164 break;
10165
10166 case GFC_ISYM_MINLOC:
10167 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
10168 break;
10169
10170 case GFC_ISYM_MAXLOC:
10171 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
10172 break;
10173
10174 case GFC_ISYM_SHAPE:
10175 gfc_conv_intrinsic_shape (se, expr);
10176 break;
10177
10178 default:
10179 gfc_conv_intrinsic_funcall (se, expr);
10180 break;
10181 }
10182
10183 return;
10184 }
10185 }
10186
10187 switch (expr->value.function.isym->id)
10188 {
10189 case GFC_ISYM_NONE:
10190 gcc_unreachable ();
10191
10192 case GFC_ISYM_REPEAT:
10193 gfc_conv_intrinsic_repeat (se, expr);
10194 break;
10195
10196 case GFC_ISYM_TRIM:
10197 gfc_conv_intrinsic_trim (se, expr);
10198 break;
10199
10200 case GFC_ISYM_SC_KIND:
10201 gfc_conv_intrinsic_sc_kind (se, expr);
10202 break;
10203
10204 case GFC_ISYM_SI_KIND:
10205 gfc_conv_intrinsic_si_kind (se, expr);
10206 break;
10207
10208 case GFC_ISYM_SR_KIND:
10209 gfc_conv_intrinsic_sr_kind (se, expr);
10210 break;
10211
10212 case GFC_ISYM_EXPONENT:
10213 gfc_conv_intrinsic_exponent (se, expr);
10214 break;
10215
10216 case GFC_ISYM_SCAN:
10217 kind = expr->value.function.actual->expr->ts.kind;
10218 if (kind == 1)
10219 fndecl = gfor_fndecl_string_scan;
10220 else if (kind == 4)
10221 fndecl = gfor_fndecl_string_scan_char4;
10222 else
10223 gcc_unreachable ();
10224
10225 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
10226 break;
10227
10228 case GFC_ISYM_VERIFY:
10229 kind = expr->value.function.actual->expr->ts.kind;
10230 if (kind == 1)
10231 fndecl = gfor_fndecl_string_verify;
10232 else if (kind == 4)
10233 fndecl = gfor_fndecl_string_verify_char4;
10234 else
10235 gcc_unreachable ();
10236
10237 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
10238 break;
10239
10240 case GFC_ISYM_ALLOCATED:
10241 gfc_conv_allocated (se, expr);
10242 break;
10243
10244 case GFC_ISYM_ASSOCIATED:
10245 gfc_conv_associated(se, expr);
10246 break;
10247
10248 case GFC_ISYM_SAME_TYPE_AS:
10249 gfc_conv_same_type_as (se, expr);
10250 break;
10251
10252 case GFC_ISYM_ABS:
10253 gfc_conv_intrinsic_abs (se, expr);
10254 break;
10255
10256 case GFC_ISYM_ADJUSTL:
10257 if (expr->ts.kind == 1)
10258 fndecl = gfor_fndecl_adjustl;
10259 else if (expr->ts.kind == 4)
10260 fndecl = gfor_fndecl_adjustl_char4;
10261 else
10262 gcc_unreachable ();
10263
10264 gfc_conv_intrinsic_adjust (se, expr, fndecl);
10265 break;
10266
10267 case GFC_ISYM_ADJUSTR:
10268 if (expr->ts.kind == 1)
10269 fndecl = gfor_fndecl_adjustr;
10270 else if (expr->ts.kind == 4)
10271 fndecl = gfor_fndecl_adjustr_char4;
10272 else
10273 gcc_unreachable ();
10274
10275 gfc_conv_intrinsic_adjust (se, expr, fndecl);
10276 break;
10277
10278 case GFC_ISYM_AIMAG:
10279 gfc_conv_intrinsic_imagpart (se, expr);
10280 break;
10281
10282 case GFC_ISYM_AINT:
10283 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
10284 break;
10285
10286 case GFC_ISYM_ALL:
10287 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
10288 break;
10289
10290 case GFC_ISYM_ANINT:
10291 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
10292 break;
10293
10294 case GFC_ISYM_AND:
10295 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
10296 break;
10297
10298 case GFC_ISYM_ANY:
10299 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
10300 break;
10301
10302 case GFC_ISYM_ACOSD:
10303 case GFC_ISYM_ASIND:
10304 case GFC_ISYM_ATAND:
10305 gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
10306 break;
10307
10308 case GFC_ISYM_COTAN:
10309 gfc_conv_intrinsic_cotan (se, expr);
10310 break;
10311
10312 case GFC_ISYM_COTAND:
10313 gfc_conv_intrinsic_cotand (se, expr);
10314 break;
10315
10316 case GFC_ISYM_ATAN2D:
10317 gfc_conv_intrinsic_atan2d (se, expr);
10318 break;
10319
10320 case GFC_ISYM_BTEST:
10321 gfc_conv_intrinsic_btest (se, expr);
10322 break;
10323
10324 case GFC_ISYM_BGE:
10325 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
10326 break;
10327
10328 case GFC_ISYM_BGT:
10329 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
10330 break;
10331
10332 case GFC_ISYM_BLE:
10333 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
10334 break;
10335
10336 case GFC_ISYM_BLT:
10337 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
10338 break;
10339
10340 case GFC_ISYM_C_ASSOCIATED:
10341 case GFC_ISYM_C_FUNLOC:
10342 case GFC_ISYM_C_LOC:
10343 conv_isocbinding_function (se, expr);
10344 break;
10345
10346 case GFC_ISYM_ACHAR:
10347 case GFC_ISYM_CHAR:
10348 gfc_conv_intrinsic_char (se, expr);
10349 break;
10350
10351 case GFC_ISYM_CONVERSION:
10352 case GFC_ISYM_DBLE:
10353 case GFC_ISYM_DFLOAT:
10354 case GFC_ISYM_FLOAT:
10355 case GFC_ISYM_LOGICAL:
10356 case GFC_ISYM_REAL:
10357 case GFC_ISYM_REALPART:
10358 case GFC_ISYM_SNGL:
10359 gfc_conv_intrinsic_conversion (se, expr);
10360 break;
10361
10362 /* Integer conversions are handled separately to make sure we get the
10363 correct rounding mode. */
10364 case GFC_ISYM_INT:
10365 case GFC_ISYM_INT2:
10366 case GFC_ISYM_INT8:
10367 case GFC_ISYM_LONG:
10368 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
10369 break;
10370
10371 case GFC_ISYM_NINT:
10372 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
10373 break;
10374
10375 case GFC_ISYM_CEILING:
10376 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
10377 break;
10378
10379 case GFC_ISYM_FLOOR:
10380 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
10381 break;
10382
10383 case GFC_ISYM_MOD:
10384 gfc_conv_intrinsic_mod (se, expr, 0);
10385 break;
10386
10387 case GFC_ISYM_MODULO:
10388 gfc_conv_intrinsic_mod (se, expr, 1);
10389 break;
10390
10391 case GFC_ISYM_CAF_GET:
10392 gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
10393 false, NULL);
10394 break;
10395
10396 case GFC_ISYM_CMPLX:
10397 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
10398 break;
10399
10400 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
10401 gfc_conv_intrinsic_iargc (se, expr);
10402 break;
10403
10404 case GFC_ISYM_COMPLEX:
10405 gfc_conv_intrinsic_cmplx (se, expr, 1);
10406 break;
10407
10408 case GFC_ISYM_CONJG:
10409 gfc_conv_intrinsic_conjg (se, expr);
10410 break;
10411
10412 case GFC_ISYM_COUNT:
10413 gfc_conv_intrinsic_count (se, expr);
10414 break;
10415
10416 case GFC_ISYM_CTIME:
10417 gfc_conv_intrinsic_ctime (se, expr);
10418 break;
10419
10420 case GFC_ISYM_DIM:
10421 gfc_conv_intrinsic_dim (se, expr);
10422 break;
10423
10424 case GFC_ISYM_DOT_PRODUCT:
10425 gfc_conv_intrinsic_dot_product (se, expr);
10426 break;
10427
10428 case GFC_ISYM_DPROD:
10429 gfc_conv_intrinsic_dprod (se, expr);
10430 break;
10431
10432 case GFC_ISYM_DSHIFTL:
10433 gfc_conv_intrinsic_dshift (se, expr, true);
10434 break;
10435
10436 case GFC_ISYM_DSHIFTR:
10437 gfc_conv_intrinsic_dshift (se, expr, false);
10438 break;
10439
10440 case GFC_ISYM_FDATE:
10441 gfc_conv_intrinsic_fdate (se, expr);
10442 break;
10443
10444 case GFC_ISYM_FRACTION:
10445 gfc_conv_intrinsic_fraction (se, expr);
10446 break;
10447
10448 case GFC_ISYM_IALL:
10449 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
10450 break;
10451
10452 case GFC_ISYM_IAND:
10453 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
10454 break;
10455
10456 case GFC_ISYM_IANY:
10457 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
10458 break;
10459
10460 case GFC_ISYM_IBCLR:
10461 gfc_conv_intrinsic_singlebitop (se, expr, 0);
10462 break;
10463
10464 case GFC_ISYM_IBITS:
10465 gfc_conv_intrinsic_ibits (se, expr);
10466 break;
10467
10468 case GFC_ISYM_IBSET:
10469 gfc_conv_intrinsic_singlebitop (se, expr, 1);
10470 break;
10471
10472 case GFC_ISYM_IACHAR:
10473 case GFC_ISYM_ICHAR:
10474 /* We assume ASCII character sequence. */
10475 gfc_conv_intrinsic_ichar (se, expr);
10476 break;
10477
10478 case GFC_ISYM_IARGC:
10479 gfc_conv_intrinsic_iargc (se, expr);
10480 break;
10481
10482 case GFC_ISYM_IEOR:
10483 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
10484 break;
10485
10486 case GFC_ISYM_INDEX:
10487 kind = expr->value.function.actual->expr->ts.kind;
10488 if (kind == 1)
10489 fndecl = gfor_fndecl_string_index;
10490 else if (kind == 4)
10491 fndecl = gfor_fndecl_string_index_char4;
10492 else
10493 gcc_unreachable ();
10494
10495 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
10496 break;
10497
10498 case GFC_ISYM_IOR:
10499 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
10500 break;
10501
10502 case GFC_ISYM_IPARITY:
10503 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
10504 break;
10505
10506 case GFC_ISYM_IS_IOSTAT_END:
10507 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
10508 break;
10509
10510 case GFC_ISYM_IS_IOSTAT_EOR:
10511 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
10512 break;
10513
10514 case GFC_ISYM_IS_CONTIGUOUS:
10515 gfc_conv_intrinsic_is_contiguous (se, expr);
10516 break;
10517
10518 case GFC_ISYM_ISNAN:
10519 gfc_conv_intrinsic_isnan (se, expr);
10520 break;
10521
10522 case GFC_ISYM_KILL:
10523 conv_intrinsic_kill (se, expr);
10524 break;
10525
10526 case GFC_ISYM_LSHIFT:
10527 gfc_conv_intrinsic_shift (se, expr, false, false);
10528 break;
10529
10530 case GFC_ISYM_RSHIFT:
10531 gfc_conv_intrinsic_shift (se, expr, true, true);
10532 break;
10533
10534 case GFC_ISYM_SHIFTA:
10535 gfc_conv_intrinsic_shift (se, expr, true, true);
10536 break;
10537
10538 case GFC_ISYM_SHIFTL:
10539 gfc_conv_intrinsic_shift (se, expr, false, false);
10540 break;
10541
10542 case GFC_ISYM_SHIFTR:
10543 gfc_conv_intrinsic_shift (se, expr, true, false);
10544 break;
10545
10546 case GFC_ISYM_ISHFT:
10547 gfc_conv_intrinsic_ishft (se, expr);
10548 break;
10549
10550 case GFC_ISYM_ISHFTC:
10551 gfc_conv_intrinsic_ishftc (se, expr);
10552 break;
10553
10554 case GFC_ISYM_LEADZ:
10555 gfc_conv_intrinsic_leadz (se, expr);
10556 break;
10557
10558 case GFC_ISYM_TRAILZ:
10559 gfc_conv_intrinsic_trailz (se, expr);
10560 break;
10561
10562 case GFC_ISYM_POPCNT:
10563 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
10564 break;
10565
10566 case GFC_ISYM_POPPAR:
10567 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
10568 break;
10569
10570 case GFC_ISYM_LBOUND:
10571 gfc_conv_intrinsic_bound (se, expr, 0);
10572 break;
10573
10574 case GFC_ISYM_LCOBOUND:
10575 conv_intrinsic_cobound (se, expr);
10576 break;
10577
10578 case GFC_ISYM_TRANSPOSE:
10579 /* The scalarizer has already been set up for reversed dimension access
10580 order ; now we just get the argument value normally. */
10581 gfc_conv_expr (se, expr->value.function.actual->expr);
10582 break;
10583
10584 case GFC_ISYM_LEN:
10585 gfc_conv_intrinsic_len (se, expr);
10586 break;
10587
10588 case GFC_ISYM_LEN_TRIM:
10589 gfc_conv_intrinsic_len_trim (se, expr);
10590 break;
10591
10592 case GFC_ISYM_LGE:
10593 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
10594 break;
10595
10596 case GFC_ISYM_LGT:
10597 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
10598 break;
10599
10600 case GFC_ISYM_LLE:
10601 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
10602 break;
10603
10604 case GFC_ISYM_LLT:
10605 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
10606 break;
10607
10608 case GFC_ISYM_MALLOC:
10609 gfc_conv_intrinsic_malloc (se, expr);
10610 break;
10611
10612 case GFC_ISYM_MASKL:
10613 gfc_conv_intrinsic_mask (se, expr, 1);
10614 break;
10615
10616 case GFC_ISYM_MASKR:
10617 gfc_conv_intrinsic_mask (se, expr, 0);
10618 break;
10619
10620 case GFC_ISYM_MAX:
10621 if (expr->ts.type == BT_CHARACTER)
10622 gfc_conv_intrinsic_minmax_char (se, expr, 1);
10623 else
10624 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
10625 break;
10626
10627 case GFC_ISYM_MAXLOC:
10628 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
10629 break;
10630
10631 case GFC_ISYM_FINDLOC:
10632 gfc_conv_intrinsic_findloc (se, expr);
10633 break;
10634
10635 case GFC_ISYM_MAXVAL:
10636 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
10637 break;
10638
10639 case GFC_ISYM_MERGE:
10640 gfc_conv_intrinsic_merge (se, expr);
10641 break;
10642
10643 case GFC_ISYM_MERGE_BITS:
10644 gfc_conv_intrinsic_merge_bits (se, expr);
10645 break;
10646
10647 case GFC_ISYM_MIN:
10648 if (expr->ts.type == BT_CHARACTER)
10649 gfc_conv_intrinsic_minmax_char (se, expr, -1);
10650 else
10651 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
10652 break;
10653
10654 case GFC_ISYM_MINLOC:
10655 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
10656 break;
10657
10658 case GFC_ISYM_MINVAL:
10659 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
10660 break;
10661
10662 case GFC_ISYM_NEAREST:
10663 gfc_conv_intrinsic_nearest (se, expr);
10664 break;
10665
10666 case GFC_ISYM_NORM2:
10667 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
10668 break;
10669
10670 case GFC_ISYM_NOT:
10671 gfc_conv_intrinsic_not (se, expr);
10672 break;
10673
10674 case GFC_ISYM_OR:
10675 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
10676 break;
10677
10678 case GFC_ISYM_PARITY:
10679 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
10680 break;
10681
10682 case GFC_ISYM_PRESENT:
10683 gfc_conv_intrinsic_present (se, expr);
10684 break;
10685
10686 case GFC_ISYM_PRODUCT:
10687 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
10688 break;
10689
10690 case GFC_ISYM_RANK:
10691 gfc_conv_intrinsic_rank (se, expr);
10692 break;
10693
10694 case GFC_ISYM_RRSPACING:
10695 gfc_conv_intrinsic_rrspacing (se, expr);
10696 break;
10697
10698 case GFC_ISYM_SET_EXPONENT:
10699 gfc_conv_intrinsic_set_exponent (se, expr);
10700 break;
10701
10702 case GFC_ISYM_SCALE:
10703 gfc_conv_intrinsic_scale (se, expr);
10704 break;
10705
10706 case GFC_ISYM_SIGN:
10707 gfc_conv_intrinsic_sign (se, expr);
10708 break;
10709
10710 case GFC_ISYM_SIZE:
10711 gfc_conv_intrinsic_size (se, expr);
10712 break;
10713
10714 case GFC_ISYM_SIZEOF:
10715 case GFC_ISYM_C_SIZEOF:
10716 gfc_conv_intrinsic_sizeof (se, expr);
10717 break;
10718
10719 case GFC_ISYM_STORAGE_SIZE:
10720 gfc_conv_intrinsic_storage_size (se, expr);
10721 break;
10722
10723 case GFC_ISYM_SPACING:
10724 gfc_conv_intrinsic_spacing (se, expr);
10725 break;
10726
10727 case GFC_ISYM_STRIDE:
10728 conv_intrinsic_stride (se, expr);
10729 break;
10730
10731 case GFC_ISYM_SUM:
10732 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
10733 break;
10734
10735 case GFC_ISYM_TEAM_NUMBER:
10736 conv_intrinsic_team_number (se, expr);
10737 break;
10738
10739 case GFC_ISYM_TRANSFER:
10740 if (se->ss && se->ss->info->useflags)
10741 /* Access the previously obtained result. */
10742 gfc_conv_tmp_array_ref (se);
10743 else
10744 gfc_conv_intrinsic_transfer (se, expr);
10745 break;
10746
10747 case GFC_ISYM_TTYNAM:
10748 gfc_conv_intrinsic_ttynam (se, expr);
10749 break;
10750
10751 case GFC_ISYM_UBOUND:
10752 gfc_conv_intrinsic_bound (se, expr, 1);
10753 break;
10754
10755 case GFC_ISYM_UCOBOUND:
10756 conv_intrinsic_cobound (se, expr);
10757 break;
10758
10759 case GFC_ISYM_XOR:
10760 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
10761 break;
10762
10763 case GFC_ISYM_LOC:
10764 gfc_conv_intrinsic_loc (se, expr);
10765 break;
10766
10767 case GFC_ISYM_THIS_IMAGE:
10768 /* For num_images() == 1, handle as LCOBOUND. */
10769 if (expr->value.function.actual->expr
10770 && flag_coarray == GFC_FCOARRAY_SINGLE)
10771 conv_intrinsic_cobound (se, expr);
10772 else
10773 trans_this_image (se, expr);
10774 break;
10775
10776 case GFC_ISYM_IMAGE_INDEX:
10777 trans_image_index (se, expr);
10778 break;
10779
10780 case GFC_ISYM_IMAGE_STATUS:
10781 conv_intrinsic_image_status (se, expr);
10782 break;
10783
10784 case GFC_ISYM_NUM_IMAGES:
10785 trans_num_images (se, expr);
10786 break;
10787
10788 case GFC_ISYM_ACCESS:
10789 case GFC_ISYM_CHDIR:
10790 case GFC_ISYM_CHMOD:
10791 case GFC_ISYM_DTIME:
10792 case GFC_ISYM_ETIME:
10793 case GFC_ISYM_EXTENDS_TYPE_OF:
10794 case GFC_ISYM_FGET:
10795 case GFC_ISYM_FGETC:
10796 case GFC_ISYM_FNUM:
10797 case GFC_ISYM_FPUT:
10798 case GFC_ISYM_FPUTC:
10799 case GFC_ISYM_FSTAT:
10800 case GFC_ISYM_FTELL:
10801 case GFC_ISYM_GETCWD:
10802 case GFC_ISYM_GETGID:
10803 case GFC_ISYM_GETPID:
10804 case GFC_ISYM_GETUID:
10805 case GFC_ISYM_HOSTNM:
10806 case GFC_ISYM_IERRNO:
10807 case GFC_ISYM_IRAND:
10808 case GFC_ISYM_ISATTY:
10809 case GFC_ISYM_JN2:
10810 case GFC_ISYM_LINK:
10811 case GFC_ISYM_LSTAT:
10812 case GFC_ISYM_MATMUL:
10813 case GFC_ISYM_MCLOCK:
10814 case GFC_ISYM_MCLOCK8:
10815 case GFC_ISYM_RAND:
10816 case GFC_ISYM_RENAME:
10817 case GFC_ISYM_SECOND:
10818 case GFC_ISYM_SECNDS:
10819 case GFC_ISYM_SIGNAL:
10820 case GFC_ISYM_STAT:
10821 case GFC_ISYM_SYMLNK:
10822 case GFC_ISYM_SYSTEM:
10823 case GFC_ISYM_TIME:
10824 case GFC_ISYM_TIME8:
10825 case GFC_ISYM_UMASK:
10826 case GFC_ISYM_UNLINK:
10827 case GFC_ISYM_YN2:
10828 gfc_conv_intrinsic_funcall (se, expr);
10829 break;
10830
10831 case GFC_ISYM_EOSHIFT:
10832 case GFC_ISYM_PACK:
10833 case GFC_ISYM_RESHAPE:
10834 /* For those, expr->rank should always be >0 and thus the if above the
10835 switch should have matched. */
10836 gcc_unreachable ();
10837 break;
10838
10839 default:
10840 gfc_conv_intrinsic_lib_function (se, expr);
10841 break;
10842 }
10843 }
10844
10845
10846 static gfc_ss *
walk_inline_intrinsic_transpose(gfc_ss * ss,gfc_expr * expr)10847 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
10848 {
10849 gfc_ss *arg_ss, *tmp_ss;
10850 gfc_actual_arglist *arg;
10851
10852 arg = expr->value.function.actual;
10853
10854 gcc_assert (arg->expr);
10855
10856 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
10857 gcc_assert (arg_ss != gfc_ss_terminator);
10858
10859 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
10860 {
10861 if (tmp_ss->info->type != GFC_SS_SCALAR
10862 && tmp_ss->info->type != GFC_SS_REFERENCE)
10863 {
10864 gcc_assert (tmp_ss->dimen == 2);
10865
10866 /* We just invert dimensions. */
10867 std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
10868 }
10869
10870 /* Stop when tmp_ss points to the last valid element of the chain... */
10871 if (tmp_ss->next == gfc_ss_terminator)
10872 break;
10873 }
10874
10875 /* ... so that we can attach the rest of the chain to it. */
10876 tmp_ss->next = ss;
10877
10878 return arg_ss;
10879 }
10880
10881
10882 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
10883 This has the side effect of reversing the nested list, so there is no
10884 need to call gfc_reverse_ss on it (the given list is assumed not to be
10885 reversed yet). */
10886
10887 static gfc_ss *
nest_loop_dimension(gfc_ss * ss,int dim)10888 nest_loop_dimension (gfc_ss *ss, int dim)
10889 {
10890 int ss_dim, i;
10891 gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
10892 gfc_loopinfo *new_loop;
10893
10894 gcc_assert (ss != gfc_ss_terminator);
10895
10896 for (; ss != gfc_ss_terminator; ss = ss->next)
10897 {
10898 new_ss = gfc_get_ss ();
10899 new_ss->next = prev_ss;
10900 new_ss->parent = ss;
10901 new_ss->info = ss->info;
10902 new_ss->info->refcount++;
10903 if (ss->dimen != 0)
10904 {
10905 gcc_assert (ss->info->type != GFC_SS_SCALAR
10906 && ss->info->type != GFC_SS_REFERENCE);
10907
10908 new_ss->dimen = 1;
10909 new_ss->dim[0] = ss->dim[dim];
10910
10911 gcc_assert (dim < ss->dimen);
10912
10913 ss_dim = --ss->dimen;
10914 for (i = dim; i < ss_dim; i++)
10915 ss->dim[i] = ss->dim[i + 1];
10916
10917 ss->dim[ss_dim] = 0;
10918 }
10919 prev_ss = new_ss;
10920
10921 if (ss->nested_ss)
10922 {
10923 ss->nested_ss->parent = new_ss;
10924 new_ss->nested_ss = ss->nested_ss;
10925 }
10926 ss->nested_ss = new_ss;
10927 }
10928
10929 new_loop = gfc_get_loopinfo ();
10930 gfc_init_loopinfo (new_loop);
10931
10932 gcc_assert (prev_ss != NULL);
10933 gcc_assert (prev_ss != gfc_ss_terminator);
10934 gfc_add_ss_to_loop (new_loop, prev_ss);
10935 return new_ss->parent;
10936 }
10937
10938
10939 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
10940 is to be inlined. */
10941
10942 static gfc_ss *
walk_inline_intrinsic_arith(gfc_ss * ss,gfc_expr * expr)10943 walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
10944 {
10945 gfc_ss *tmp_ss, *tail, *array_ss;
10946 gfc_actual_arglist *arg1, *arg2, *arg3;
10947 int sum_dim;
10948 bool scalar_mask = false;
10949
10950 /* The rank of the result will be determined later. */
10951 arg1 = expr->value.function.actual;
10952 arg2 = arg1->next;
10953 arg3 = arg2->next;
10954 gcc_assert (arg3 != NULL);
10955
10956 if (expr->rank == 0)
10957 return ss;
10958
10959 tmp_ss = gfc_ss_terminator;
10960
10961 if (arg3->expr)
10962 {
10963 gfc_ss *mask_ss;
10964
10965 mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
10966 if (mask_ss == tmp_ss)
10967 scalar_mask = 1;
10968
10969 tmp_ss = mask_ss;
10970 }
10971
10972 array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
10973 gcc_assert (array_ss != tmp_ss);
10974
10975 /* Odd thing: If the mask is scalar, it is used by the frontend after
10976 the array (to make an if around the nested loop). Thus it shall
10977 be after array_ss once the gfc_ss list is reversed. */
10978 if (scalar_mask)
10979 tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
10980 else
10981 tmp_ss = array_ss;
10982
10983 /* "Hide" the dimension on which we will sum in the first arg's scalarization
10984 chain. */
10985 sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
10986 tail = nest_loop_dimension (tmp_ss, sum_dim);
10987 tail->next = ss;
10988
10989 return tmp_ss;
10990 }
10991
10992
10993 static gfc_ss *
walk_inline_intrinsic_function(gfc_ss * ss,gfc_expr * expr)10994 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
10995 {
10996
10997 switch (expr->value.function.isym->id)
10998 {
10999 case GFC_ISYM_PRODUCT:
11000 case GFC_ISYM_SUM:
11001 return walk_inline_intrinsic_arith (ss, expr);
11002
11003 case GFC_ISYM_TRANSPOSE:
11004 return walk_inline_intrinsic_transpose (ss, expr);
11005
11006 default:
11007 gcc_unreachable ();
11008 }
11009 gcc_unreachable ();
11010 }
11011
11012
11013 /* This generates code to execute before entering the scalarization loop.
11014 Currently does nothing. */
11015
11016 void
gfc_add_intrinsic_ss_code(gfc_loopinfo * loop ATTRIBUTE_UNUSED,gfc_ss * ss)11017 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
11018 {
11019 switch (ss->info->expr->value.function.isym->id)
11020 {
11021 case GFC_ISYM_UBOUND:
11022 case GFC_ISYM_LBOUND:
11023 case GFC_ISYM_UCOBOUND:
11024 case GFC_ISYM_LCOBOUND:
11025 case GFC_ISYM_THIS_IMAGE:
11026 break;
11027
11028 default:
11029 gcc_unreachable ();
11030 }
11031 }
11032
11033
11034 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
11035 are expanded into code inside the scalarization loop. */
11036
11037 static gfc_ss *
gfc_walk_intrinsic_bound(gfc_ss * ss,gfc_expr * expr)11038 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
11039 {
11040 if (expr->value.function.actual->expr->ts.type == BT_CLASS)
11041 gfc_add_class_array_ref (expr->value.function.actual->expr);
11042
11043 /* The two argument version returns a scalar. */
11044 if (expr->value.function.actual->next->expr)
11045 return ss;
11046
11047 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
11048 }
11049
11050
11051 /* Walk an intrinsic array libcall. */
11052
11053 static gfc_ss *
gfc_walk_intrinsic_libfunc(gfc_ss * ss,gfc_expr * expr)11054 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
11055 {
11056 gcc_assert (expr->rank > 0);
11057 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
11058 }
11059
11060
11061 /* Return whether the function call expression EXPR will be expanded
11062 inline by gfc_conv_intrinsic_function. */
11063
11064 bool
gfc_inline_intrinsic_function_p(gfc_expr * expr)11065 gfc_inline_intrinsic_function_p (gfc_expr *expr)
11066 {
11067 gfc_actual_arglist *args, *dim_arg, *mask_arg;
11068 gfc_expr *maskexpr;
11069
11070 if (!expr->value.function.isym)
11071 return false;
11072
11073 switch (expr->value.function.isym->id)
11074 {
11075 case GFC_ISYM_PRODUCT:
11076 case GFC_ISYM_SUM:
11077 /* Disable inline expansion if code size matters. */
11078 if (optimize_size)
11079 return false;
11080
11081 args = expr->value.function.actual;
11082 dim_arg = args->next;
11083
11084 /* We need to be able to subset the SUM argument at compile-time. */
11085 if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
11086 return false;
11087
11088 /* FIXME: If MASK is optional for a more than two-dimensional
11089 argument, the scalarizer gets confused if the mask is
11090 absent. See PR 82995. For now, fall back to the library
11091 function. */
11092
11093 mask_arg = dim_arg->next;
11094 maskexpr = mask_arg->expr;
11095
11096 if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
11097 && maskexpr->symtree->n.sym->attr.dummy
11098 && maskexpr->symtree->n.sym->attr.optional)
11099 return false;
11100
11101 return true;
11102
11103 case GFC_ISYM_TRANSPOSE:
11104 return true;
11105
11106 default:
11107 return false;
11108 }
11109 }
11110
11111
11112 /* Returns nonzero if the specified intrinsic function call maps directly to
11113 an external library call. Should only be used for functions that return
11114 arrays. */
11115
11116 int
gfc_is_intrinsic_libcall(gfc_expr * expr)11117 gfc_is_intrinsic_libcall (gfc_expr * expr)
11118 {
11119 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
11120 gcc_assert (expr->rank > 0);
11121
11122 if (gfc_inline_intrinsic_function_p (expr))
11123 return 0;
11124
11125 switch (expr->value.function.isym->id)
11126 {
11127 case GFC_ISYM_ALL:
11128 case GFC_ISYM_ANY:
11129 case GFC_ISYM_COUNT:
11130 case GFC_ISYM_FINDLOC:
11131 case GFC_ISYM_JN2:
11132 case GFC_ISYM_IANY:
11133 case GFC_ISYM_IALL:
11134 case GFC_ISYM_IPARITY:
11135 case GFC_ISYM_MATMUL:
11136 case GFC_ISYM_MAXLOC:
11137 case GFC_ISYM_MAXVAL:
11138 case GFC_ISYM_MINLOC:
11139 case GFC_ISYM_MINVAL:
11140 case GFC_ISYM_NORM2:
11141 case GFC_ISYM_PARITY:
11142 case GFC_ISYM_PRODUCT:
11143 case GFC_ISYM_SUM:
11144 case GFC_ISYM_SHAPE:
11145 case GFC_ISYM_SPREAD:
11146 case GFC_ISYM_YN2:
11147 /* Ignore absent optional parameters. */
11148 return 1;
11149
11150 case GFC_ISYM_CSHIFT:
11151 case GFC_ISYM_EOSHIFT:
11152 case GFC_ISYM_GET_TEAM:
11153 case GFC_ISYM_FAILED_IMAGES:
11154 case GFC_ISYM_STOPPED_IMAGES:
11155 case GFC_ISYM_PACK:
11156 case GFC_ISYM_RESHAPE:
11157 case GFC_ISYM_UNPACK:
11158 /* Pass absent optional parameters. */
11159 return 2;
11160
11161 default:
11162 return 0;
11163 }
11164 }
11165
11166 /* Walk an intrinsic function. */
11167 gfc_ss *
gfc_walk_intrinsic_function(gfc_ss * ss,gfc_expr * expr,gfc_intrinsic_sym * isym)11168 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
11169 gfc_intrinsic_sym * isym)
11170 {
11171 gcc_assert (isym);
11172
11173 if (isym->elemental)
11174 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
11175 NULL, GFC_SS_SCALAR);
11176
11177 if (expr->rank == 0)
11178 return ss;
11179
11180 if (gfc_inline_intrinsic_function_p (expr))
11181 return walk_inline_intrinsic_function (ss, expr);
11182
11183 if (gfc_is_intrinsic_libcall (expr))
11184 return gfc_walk_intrinsic_libfunc (ss, expr);
11185
11186 /* Special cases. */
11187 switch (isym->id)
11188 {
11189 case GFC_ISYM_LBOUND:
11190 case GFC_ISYM_LCOBOUND:
11191 case GFC_ISYM_UBOUND:
11192 case GFC_ISYM_UCOBOUND:
11193 case GFC_ISYM_THIS_IMAGE:
11194 return gfc_walk_intrinsic_bound (ss, expr);
11195
11196 case GFC_ISYM_TRANSFER:
11197 case GFC_ISYM_CAF_GET:
11198 return gfc_walk_intrinsic_libfunc (ss, expr);
11199
11200 default:
11201 /* This probably meant someone forgot to add an intrinsic to the above
11202 list(s) when they implemented it, or something's gone horribly
11203 wrong. */
11204 gcc_unreachable ();
11205 }
11206 }
11207
11208 static tree
conv_co_collective(gfc_code * code)11209 conv_co_collective (gfc_code *code)
11210 {
11211 gfc_se argse;
11212 stmtblock_t block, post_block;
11213 tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
11214 gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
11215
11216 gfc_start_block (&block);
11217 gfc_init_block (&post_block);
11218
11219 if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
11220 {
11221 opr_expr = code->ext.actual->next->expr;
11222 image_idx_expr = code->ext.actual->next->next->expr;
11223 stat_expr = code->ext.actual->next->next->next->expr;
11224 errmsg_expr = code->ext.actual->next->next->next->next->expr;
11225 }
11226 else
11227 {
11228 opr_expr = NULL;
11229 image_idx_expr = code->ext.actual->next->expr;
11230 stat_expr = code->ext.actual->next->next->expr;
11231 errmsg_expr = code->ext.actual->next->next->next->expr;
11232 }
11233
11234 /* stat. */
11235 if (stat_expr)
11236 {
11237 gfc_init_se (&argse, NULL);
11238 gfc_conv_expr (&argse, stat_expr);
11239 gfc_add_block_to_block (&block, &argse.pre);
11240 gfc_add_block_to_block (&post_block, &argse.post);
11241 stat = argse.expr;
11242 if (flag_coarray != GFC_FCOARRAY_SINGLE)
11243 stat = gfc_build_addr_expr (NULL_TREE, stat);
11244 }
11245 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
11246 stat = NULL_TREE;
11247 else
11248 stat = null_pointer_node;
11249
11250 /* Early exit for GFC_FCOARRAY_SINGLE. */
11251 if (flag_coarray == GFC_FCOARRAY_SINGLE)
11252 {
11253 if (stat != NULL_TREE)
11254 gfc_add_modify (&block, stat,
11255 fold_convert (TREE_TYPE (stat), integer_zero_node));
11256 return gfc_finish_block (&block);
11257 }
11258
11259 /* Handle the array. */
11260 gfc_init_se (&argse, NULL);
11261 if (code->ext.actual->expr->rank == 0)
11262 {
11263 symbol_attribute attr;
11264 gfc_clear_attr (&attr);
11265 gfc_init_se (&argse, NULL);
11266 gfc_conv_expr (&argse, code->ext.actual->expr);
11267 gfc_add_block_to_block (&block, &argse.pre);
11268 gfc_add_block_to_block (&post_block, &argse.post);
11269 array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
11270 array = gfc_build_addr_expr (NULL_TREE, array);
11271 }
11272 else
11273 {
11274 argse.want_pointer = 1;
11275 gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
11276 array = argse.expr;
11277 }
11278
11279 gfc_add_block_to_block (&block, &argse.pre);
11280 gfc_add_block_to_block (&post_block, &argse.post);
11281
11282 if (code->ext.actual->expr->ts.type == BT_CHARACTER)
11283 strlen = argse.string_length;
11284 else
11285 strlen = integer_zero_node;
11286
11287 /* image_index. */
11288 if (image_idx_expr)
11289 {
11290 gfc_init_se (&argse, NULL);
11291 gfc_conv_expr (&argse, image_idx_expr);
11292 gfc_add_block_to_block (&block, &argse.pre);
11293 gfc_add_block_to_block (&post_block, &argse.post);
11294 image_index = fold_convert (integer_type_node, argse.expr);
11295 }
11296 else
11297 image_index = integer_zero_node;
11298
11299 /* errmsg. */
11300 if (errmsg_expr)
11301 {
11302 gfc_init_se (&argse, NULL);
11303 gfc_conv_expr (&argse, errmsg_expr);
11304 gfc_add_block_to_block (&block, &argse.pre);
11305 gfc_add_block_to_block (&post_block, &argse.post);
11306 errmsg = argse.expr;
11307 errmsg_len = fold_convert (size_type_node, argse.string_length);
11308 }
11309 else
11310 {
11311 errmsg = null_pointer_node;
11312 errmsg_len = build_zero_cst (size_type_node);
11313 }
11314
11315 /* Generate the function call. */
11316 switch (code->resolved_isym->id)
11317 {
11318 case GFC_ISYM_CO_BROADCAST:
11319 fndecl = gfor_fndecl_co_broadcast;
11320 break;
11321 case GFC_ISYM_CO_MAX:
11322 fndecl = gfor_fndecl_co_max;
11323 break;
11324 case GFC_ISYM_CO_MIN:
11325 fndecl = gfor_fndecl_co_min;
11326 break;
11327 case GFC_ISYM_CO_REDUCE:
11328 fndecl = gfor_fndecl_co_reduce;
11329 break;
11330 case GFC_ISYM_CO_SUM:
11331 fndecl = gfor_fndecl_co_sum;
11332 break;
11333 default:
11334 gcc_unreachable ();
11335 }
11336
11337 gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
11338 ? code->ext.actual->expr->ts.u.derived : NULL;
11339
11340 if (derived && derived->attr.alloc_comp
11341 && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
11342 /* The derived type has the attribute 'alloc_comp'. */
11343 {
11344 tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
11345 code->ext.actual->expr->rank,
11346 image_index, stat, errmsg, errmsg_len);
11347 gfc_add_expr_to_block (&block, tmp);
11348 }
11349 else
11350 {
11351 if (code->resolved_isym->id == GFC_ISYM_CO_SUM
11352 || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
11353 fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
11354 image_index, stat, errmsg, errmsg_len);
11355 else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
11356 fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
11357 image_index, stat, errmsg,
11358 strlen, errmsg_len);
11359 else
11360 {
11361 tree opr, opr_flags;
11362
11363 // FIXME: Handle TS29113's bind(C) strings with descriptor.
11364 int opr_flag_int;
11365 if (gfc_is_proc_ptr_comp (opr_expr))
11366 {
11367 gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
11368 opr_flag_int = sym->attr.dimension
11369 || (sym->ts.type == BT_CHARACTER
11370 && !sym->attr.is_bind_c)
11371 ? GFC_CAF_BYREF : 0;
11372 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
11373 && !sym->attr.is_bind_c
11374 ? GFC_CAF_HIDDENLEN : 0;
11375 opr_flag_int |= sym->formal->sym->attr.value
11376 ? GFC_CAF_ARG_VALUE : 0;
11377 }
11378 else
11379 {
11380 opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
11381 ? GFC_CAF_BYREF : 0;
11382 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
11383 && !opr_expr->symtree->n.sym->attr.is_bind_c
11384 ? GFC_CAF_HIDDENLEN : 0;
11385 opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
11386 ? GFC_CAF_ARG_VALUE : 0;
11387 }
11388 opr_flags = build_int_cst (integer_type_node, opr_flag_int);
11389 gfc_conv_expr (&argse, opr_expr);
11390 opr = argse.expr;
11391 fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
11392 opr_flags, image_index, stat, errmsg,
11393 strlen, errmsg_len);
11394 }
11395 }
11396
11397 gfc_add_expr_to_block (&block, fndecl);
11398 gfc_add_block_to_block (&block, &post_block);
11399
11400 return gfc_finish_block (&block);
11401 }
11402
11403
11404 static tree
conv_intrinsic_atomic_op(gfc_code * code)11405 conv_intrinsic_atomic_op (gfc_code *code)
11406 {
11407 gfc_se argse;
11408 tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
11409 stmtblock_t block, post_block;
11410 gfc_expr *atom_expr = code->ext.actual->expr;
11411 gfc_expr *stat_expr;
11412 built_in_function fn;
11413
11414 if (atom_expr->expr_type == EXPR_FUNCTION
11415 && atom_expr->value.function.isym
11416 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11417 atom_expr = atom_expr->value.function.actual->expr;
11418
11419 gfc_start_block (&block);
11420 gfc_init_block (&post_block);
11421
11422 gfc_init_se (&argse, NULL);
11423 argse.want_pointer = 1;
11424 gfc_conv_expr (&argse, atom_expr);
11425 gfc_add_block_to_block (&block, &argse.pre);
11426 gfc_add_block_to_block (&post_block, &argse.post);
11427 atom = argse.expr;
11428
11429 gfc_init_se (&argse, NULL);
11430 if (flag_coarray == GFC_FCOARRAY_LIB
11431 && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
11432 argse.want_pointer = 1;
11433 gfc_conv_expr (&argse, code->ext.actual->next->expr);
11434 gfc_add_block_to_block (&block, &argse.pre);
11435 gfc_add_block_to_block (&post_block, &argse.post);
11436 value = argse.expr;
11437
11438 switch (code->resolved_isym->id)
11439 {
11440 case GFC_ISYM_ATOMIC_ADD:
11441 case GFC_ISYM_ATOMIC_AND:
11442 case GFC_ISYM_ATOMIC_DEF:
11443 case GFC_ISYM_ATOMIC_OR:
11444 case GFC_ISYM_ATOMIC_XOR:
11445 stat_expr = code->ext.actual->next->next->expr;
11446 if (flag_coarray == GFC_FCOARRAY_LIB)
11447 old = null_pointer_node;
11448 break;
11449 default:
11450 gfc_init_se (&argse, NULL);
11451 if (flag_coarray == GFC_FCOARRAY_LIB)
11452 argse.want_pointer = 1;
11453 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
11454 gfc_add_block_to_block (&block, &argse.pre);
11455 gfc_add_block_to_block (&post_block, &argse.post);
11456 old = argse.expr;
11457 stat_expr = code->ext.actual->next->next->next->expr;
11458 }
11459
11460 /* STAT= */
11461 if (stat_expr != NULL)
11462 {
11463 gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
11464 gfc_init_se (&argse, NULL);
11465 if (flag_coarray == GFC_FCOARRAY_LIB)
11466 argse.want_pointer = 1;
11467 gfc_conv_expr_val (&argse, stat_expr);
11468 gfc_add_block_to_block (&block, &argse.pre);
11469 gfc_add_block_to_block (&post_block, &argse.post);
11470 stat = argse.expr;
11471 }
11472 else if (flag_coarray == GFC_FCOARRAY_LIB)
11473 stat = null_pointer_node;
11474
11475 if (flag_coarray == GFC_FCOARRAY_LIB)
11476 {
11477 tree image_index, caf_decl, offset, token;
11478 int op;
11479
11480 switch (code->resolved_isym->id)
11481 {
11482 case GFC_ISYM_ATOMIC_ADD:
11483 case GFC_ISYM_ATOMIC_FETCH_ADD:
11484 op = (int) GFC_CAF_ATOMIC_ADD;
11485 break;
11486 case GFC_ISYM_ATOMIC_AND:
11487 case GFC_ISYM_ATOMIC_FETCH_AND:
11488 op = (int) GFC_CAF_ATOMIC_AND;
11489 break;
11490 case GFC_ISYM_ATOMIC_OR:
11491 case GFC_ISYM_ATOMIC_FETCH_OR:
11492 op = (int) GFC_CAF_ATOMIC_OR;
11493 break;
11494 case GFC_ISYM_ATOMIC_XOR:
11495 case GFC_ISYM_ATOMIC_FETCH_XOR:
11496 op = (int) GFC_CAF_ATOMIC_XOR;
11497 break;
11498 case GFC_ISYM_ATOMIC_DEF:
11499 op = 0; /* Unused. */
11500 break;
11501 default:
11502 gcc_unreachable ();
11503 }
11504
11505 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
11506 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
11507 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
11508
11509 if (gfc_is_coindexed (atom_expr))
11510 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
11511 else
11512 image_index = integer_zero_node;
11513
11514 if (!POINTER_TYPE_P (TREE_TYPE (value)))
11515 {
11516 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
11517 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
11518 value = gfc_build_addr_expr (NULL_TREE, tmp);
11519 }
11520
11521 gfc_init_se (&argse, NULL);
11522 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
11523 atom_expr);
11524
11525 gfc_add_block_to_block (&block, &argse.pre);
11526 if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
11527 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
11528 token, offset, image_index, value, stat,
11529 build_int_cst (integer_type_node,
11530 (int) atom_expr->ts.type),
11531 build_int_cst (integer_type_node,
11532 (int) atom_expr->ts.kind));
11533 else
11534 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
11535 build_int_cst (integer_type_node, op),
11536 token, offset, image_index, value, old, stat,
11537 build_int_cst (integer_type_node,
11538 (int) atom_expr->ts.type),
11539 build_int_cst (integer_type_node,
11540 (int) atom_expr->ts.kind));
11541
11542 gfc_add_expr_to_block (&block, tmp);
11543 gfc_add_block_to_block (&block, &argse.post);
11544 gfc_add_block_to_block (&block, &post_block);
11545 return gfc_finish_block (&block);
11546 }
11547
11548
11549 switch (code->resolved_isym->id)
11550 {
11551 case GFC_ISYM_ATOMIC_ADD:
11552 case GFC_ISYM_ATOMIC_FETCH_ADD:
11553 fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
11554 break;
11555 case GFC_ISYM_ATOMIC_AND:
11556 case GFC_ISYM_ATOMIC_FETCH_AND:
11557 fn = BUILT_IN_ATOMIC_FETCH_AND_N;
11558 break;
11559 case GFC_ISYM_ATOMIC_DEF:
11560 fn = BUILT_IN_ATOMIC_STORE_N;
11561 break;
11562 case GFC_ISYM_ATOMIC_OR:
11563 case GFC_ISYM_ATOMIC_FETCH_OR:
11564 fn = BUILT_IN_ATOMIC_FETCH_OR_N;
11565 break;
11566 case GFC_ISYM_ATOMIC_XOR:
11567 case GFC_ISYM_ATOMIC_FETCH_XOR:
11568 fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
11569 break;
11570 default:
11571 gcc_unreachable ();
11572 }
11573
11574 tmp = TREE_TYPE (TREE_TYPE (atom));
11575 fn = (built_in_function) ((int) fn
11576 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
11577 + 1);
11578 tree itype = TREE_TYPE (TREE_TYPE (atom));
11579 tmp = builtin_decl_explicit (fn);
11580
11581 switch (code->resolved_isym->id)
11582 {
11583 case GFC_ISYM_ATOMIC_ADD:
11584 case GFC_ISYM_ATOMIC_AND:
11585 case GFC_ISYM_ATOMIC_DEF:
11586 case GFC_ISYM_ATOMIC_OR:
11587 case GFC_ISYM_ATOMIC_XOR:
11588 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
11589 fold_convert (itype, value),
11590 build_int_cst (NULL, MEMMODEL_RELAXED));
11591 gfc_add_expr_to_block (&block, tmp);
11592 break;
11593 default:
11594 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
11595 fold_convert (itype, value),
11596 build_int_cst (NULL, MEMMODEL_RELAXED));
11597 gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
11598 break;
11599 }
11600
11601 if (stat != NULL_TREE)
11602 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
11603 gfc_add_block_to_block (&block, &post_block);
11604 return gfc_finish_block (&block);
11605 }
11606
11607
11608 static tree
conv_intrinsic_atomic_ref(gfc_code * code)11609 conv_intrinsic_atomic_ref (gfc_code *code)
11610 {
11611 gfc_se argse;
11612 tree tmp, atom, value, stat = NULL_TREE;
11613 stmtblock_t block, post_block;
11614 built_in_function fn;
11615 gfc_expr *atom_expr = code->ext.actual->next->expr;
11616
11617 if (atom_expr->expr_type == EXPR_FUNCTION
11618 && atom_expr->value.function.isym
11619 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11620 atom_expr = atom_expr->value.function.actual->expr;
11621
11622 gfc_start_block (&block);
11623 gfc_init_block (&post_block);
11624 gfc_init_se (&argse, NULL);
11625 argse.want_pointer = 1;
11626 gfc_conv_expr (&argse, atom_expr);
11627 gfc_add_block_to_block (&block, &argse.pre);
11628 gfc_add_block_to_block (&post_block, &argse.post);
11629 atom = argse.expr;
11630
11631 gfc_init_se (&argse, NULL);
11632 if (flag_coarray == GFC_FCOARRAY_LIB
11633 && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
11634 argse.want_pointer = 1;
11635 gfc_conv_expr (&argse, code->ext.actual->expr);
11636 gfc_add_block_to_block (&block, &argse.pre);
11637 gfc_add_block_to_block (&post_block, &argse.post);
11638 value = argse.expr;
11639
11640 /* STAT= */
11641 if (code->ext.actual->next->next->expr != NULL)
11642 {
11643 gcc_assert (code->ext.actual->next->next->expr->expr_type
11644 == EXPR_VARIABLE);
11645 gfc_init_se (&argse, NULL);
11646 if (flag_coarray == GFC_FCOARRAY_LIB)
11647 argse.want_pointer = 1;
11648 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
11649 gfc_add_block_to_block (&block, &argse.pre);
11650 gfc_add_block_to_block (&post_block, &argse.post);
11651 stat = argse.expr;
11652 }
11653 else if (flag_coarray == GFC_FCOARRAY_LIB)
11654 stat = null_pointer_node;
11655
11656 if (flag_coarray == GFC_FCOARRAY_LIB)
11657 {
11658 tree image_index, caf_decl, offset, token;
11659 tree orig_value = NULL_TREE, vardecl = NULL_TREE;
11660
11661 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
11662 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
11663 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
11664
11665 if (gfc_is_coindexed (atom_expr))
11666 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
11667 else
11668 image_index = integer_zero_node;
11669
11670 gfc_init_se (&argse, NULL);
11671 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
11672 atom_expr);
11673 gfc_add_block_to_block (&block, &argse.pre);
11674
11675 /* Different type, need type conversion. */
11676 if (!POINTER_TYPE_P (TREE_TYPE (value)))
11677 {
11678 vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
11679 orig_value = value;
11680 value = gfc_build_addr_expr (NULL_TREE, vardecl);
11681 }
11682
11683 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
11684 token, offset, image_index, value, stat,
11685 build_int_cst (integer_type_node,
11686 (int) atom_expr->ts.type),
11687 build_int_cst (integer_type_node,
11688 (int) atom_expr->ts.kind));
11689 gfc_add_expr_to_block (&block, tmp);
11690 if (vardecl != NULL_TREE)
11691 gfc_add_modify (&block, orig_value,
11692 fold_convert (TREE_TYPE (orig_value), vardecl));
11693 gfc_add_block_to_block (&block, &argse.post);
11694 gfc_add_block_to_block (&block, &post_block);
11695 return gfc_finish_block (&block);
11696 }
11697
11698 tmp = TREE_TYPE (TREE_TYPE (atom));
11699 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
11700 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
11701 + 1);
11702 tmp = builtin_decl_explicit (fn);
11703 tmp = build_call_expr_loc (input_location, tmp, 2, atom,
11704 build_int_cst (integer_type_node,
11705 MEMMODEL_RELAXED));
11706 gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
11707
11708 if (stat != NULL_TREE)
11709 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
11710 gfc_add_block_to_block (&block, &post_block);
11711 return gfc_finish_block (&block);
11712 }
11713
11714
11715 static tree
conv_intrinsic_atomic_cas(gfc_code * code)11716 conv_intrinsic_atomic_cas (gfc_code *code)
11717 {
11718 gfc_se argse;
11719 tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
11720 stmtblock_t block, post_block;
11721 built_in_function fn;
11722 gfc_expr *atom_expr = code->ext.actual->expr;
11723
11724 if (atom_expr->expr_type == EXPR_FUNCTION
11725 && atom_expr->value.function.isym
11726 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11727 atom_expr = atom_expr->value.function.actual->expr;
11728
11729 gfc_init_block (&block);
11730 gfc_init_block (&post_block);
11731 gfc_init_se (&argse, NULL);
11732 argse.want_pointer = 1;
11733 gfc_conv_expr (&argse, atom_expr);
11734 atom = argse.expr;
11735
11736 gfc_init_se (&argse, NULL);
11737 if (flag_coarray == GFC_FCOARRAY_LIB)
11738 argse.want_pointer = 1;
11739 gfc_conv_expr (&argse, code->ext.actual->next->expr);
11740 gfc_add_block_to_block (&block, &argse.pre);
11741 gfc_add_block_to_block (&post_block, &argse.post);
11742 old = argse.expr;
11743
11744 gfc_init_se (&argse, NULL);
11745 if (flag_coarray == GFC_FCOARRAY_LIB)
11746 argse.want_pointer = 1;
11747 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
11748 gfc_add_block_to_block (&block, &argse.pre);
11749 gfc_add_block_to_block (&post_block, &argse.post);
11750 comp = argse.expr;
11751
11752 gfc_init_se (&argse, NULL);
11753 if (flag_coarray == GFC_FCOARRAY_LIB
11754 && code->ext.actual->next->next->next->expr->ts.kind
11755 == atom_expr->ts.kind)
11756 argse.want_pointer = 1;
11757 gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
11758 gfc_add_block_to_block (&block, &argse.pre);
11759 gfc_add_block_to_block (&post_block, &argse.post);
11760 new_val = argse.expr;
11761
11762 /* STAT= */
11763 if (code->ext.actual->next->next->next->next->expr != NULL)
11764 {
11765 gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
11766 == EXPR_VARIABLE);
11767 gfc_init_se (&argse, NULL);
11768 if (flag_coarray == GFC_FCOARRAY_LIB)
11769 argse.want_pointer = 1;
11770 gfc_conv_expr_val (&argse,
11771 code->ext.actual->next->next->next->next->expr);
11772 gfc_add_block_to_block (&block, &argse.pre);
11773 gfc_add_block_to_block (&post_block, &argse.post);
11774 stat = argse.expr;
11775 }
11776 else if (flag_coarray == GFC_FCOARRAY_LIB)
11777 stat = null_pointer_node;
11778
11779 if (flag_coarray == GFC_FCOARRAY_LIB)
11780 {
11781 tree image_index, caf_decl, offset, token;
11782
11783 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
11784 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
11785 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
11786
11787 if (gfc_is_coindexed (atom_expr))
11788 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
11789 else
11790 image_index = integer_zero_node;
11791
11792 if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
11793 {
11794 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
11795 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
11796 new_val = gfc_build_addr_expr (NULL_TREE, tmp);
11797 }
11798
11799 /* Convert a constant to a pointer. */
11800 if (!POINTER_TYPE_P (TREE_TYPE (comp)))
11801 {
11802 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
11803 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
11804 comp = gfc_build_addr_expr (NULL_TREE, tmp);
11805 }
11806
11807 gfc_init_se (&argse, NULL);
11808 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
11809 atom_expr);
11810 gfc_add_block_to_block (&block, &argse.pre);
11811
11812 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
11813 token, offset, image_index, old, comp, new_val,
11814 stat, build_int_cst (integer_type_node,
11815 (int) atom_expr->ts.type),
11816 build_int_cst (integer_type_node,
11817 (int) atom_expr->ts.kind));
11818 gfc_add_expr_to_block (&block, tmp);
11819 gfc_add_block_to_block (&block, &argse.post);
11820 gfc_add_block_to_block (&block, &post_block);
11821 return gfc_finish_block (&block);
11822 }
11823
11824 tmp = TREE_TYPE (TREE_TYPE (atom));
11825 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
11826 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
11827 + 1);
11828 tmp = builtin_decl_explicit (fn);
11829
11830 gfc_add_modify (&block, old, comp);
11831 tmp = build_call_expr_loc (input_location, tmp, 6, atom,
11832 gfc_build_addr_expr (NULL, old),
11833 fold_convert (TREE_TYPE (old), new_val),
11834 boolean_false_node,
11835 build_int_cst (NULL, MEMMODEL_RELAXED),
11836 build_int_cst (NULL, MEMMODEL_RELAXED));
11837 gfc_add_expr_to_block (&block, tmp);
11838
11839 if (stat != NULL_TREE)
11840 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
11841 gfc_add_block_to_block (&block, &post_block);
11842 return gfc_finish_block (&block);
11843 }
11844
11845 static tree
conv_intrinsic_event_query(gfc_code * code)11846 conv_intrinsic_event_query (gfc_code *code)
11847 {
11848 gfc_se se, argse;
11849 tree stat = NULL_TREE, stat2 = NULL_TREE;
11850 tree count = NULL_TREE, count2 = NULL_TREE;
11851
11852 gfc_expr *event_expr = code->ext.actual->expr;
11853
11854 if (code->ext.actual->next->next->expr)
11855 {
11856 gcc_assert (code->ext.actual->next->next->expr->expr_type
11857 == EXPR_VARIABLE);
11858 gfc_init_se (&argse, NULL);
11859 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
11860 stat = argse.expr;
11861 }
11862 else if (flag_coarray == GFC_FCOARRAY_LIB)
11863 stat = null_pointer_node;
11864
11865 if (code->ext.actual->next->expr)
11866 {
11867 gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
11868 gfc_init_se (&argse, NULL);
11869 gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
11870 count = argse.expr;
11871 }
11872
11873 gfc_start_block (&se.pre);
11874 if (flag_coarray == GFC_FCOARRAY_LIB)
11875 {
11876 tree tmp, token, image_index;
11877 tree index = build_zero_cst (gfc_array_index_type);
11878
11879 if (event_expr->expr_type == EXPR_FUNCTION
11880 && event_expr->value.function.isym
11881 && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11882 event_expr = event_expr->value.function.actual->expr;
11883
11884 tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
11885
11886 if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
11887 || event_expr->symtree->n.sym->ts.u.derived->from_intmod
11888 != INTMOD_ISO_FORTRAN_ENV
11889 || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
11890 != ISOFORTRAN_EVENT_TYPE)
11891 {
11892 gfc_error ("Sorry, the event component of derived type at %L is not "
11893 "yet supported", &event_expr->where);
11894 return NULL_TREE;
11895 }
11896
11897 if (gfc_is_coindexed (event_expr))
11898 {
11899 gfc_error ("The event variable at %L shall not be coindexed",
11900 &event_expr->where);
11901 return NULL_TREE;
11902 }
11903
11904 image_index = integer_zero_node;
11905
11906 gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
11907 event_expr);
11908
11909 /* For arrays, obtain the array index. */
11910 if (gfc_expr_attr (event_expr).dimension)
11911 {
11912 tree desc, tmp, extent, lbound, ubound;
11913 gfc_array_ref *ar, ar2;
11914 int i;
11915
11916 /* TODO: Extend this, once DT components are supported. */
11917 ar = &event_expr->ref->u.ar;
11918 ar2 = *ar;
11919 memset (ar, '\0', sizeof (*ar));
11920 ar->as = ar2.as;
11921 ar->type = AR_FULL;
11922
11923 gfc_init_se (&argse, NULL);
11924 argse.descriptor_only = 1;
11925 gfc_conv_expr_descriptor (&argse, event_expr);
11926 gfc_add_block_to_block (&se.pre, &argse.pre);
11927 desc = argse.expr;
11928 *ar = ar2;
11929
11930 extent = build_one_cst (gfc_array_index_type);
11931 for (i = 0; i < ar->dimen; i++)
11932 {
11933 gfc_init_se (&argse, NULL);
11934 gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
11935 gfc_add_block_to_block (&argse.pre, &argse.pre);
11936 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
11937 tmp = fold_build2_loc (input_location, MINUS_EXPR,
11938 TREE_TYPE (lbound), argse.expr, lbound);
11939 tmp = fold_build2_loc (input_location, MULT_EXPR,
11940 TREE_TYPE (tmp), extent, tmp);
11941 index = fold_build2_loc (input_location, PLUS_EXPR,
11942 TREE_TYPE (tmp), index, tmp);
11943 if (i < ar->dimen - 1)
11944 {
11945 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
11946 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11947 extent = fold_build2_loc (input_location, MULT_EXPR,
11948 TREE_TYPE (tmp), extent, tmp);
11949 }
11950 }
11951 }
11952
11953 if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
11954 {
11955 count2 = count;
11956 count = gfc_create_var (integer_type_node, "count");
11957 }
11958
11959 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
11960 {
11961 stat2 = stat;
11962 stat = gfc_create_var (integer_type_node, "stat");
11963 }
11964
11965 index = fold_convert (size_type_node, index);
11966 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
11967 token, index, image_index, count
11968 ? gfc_build_addr_expr (NULL, count) : count,
11969 stat != null_pointer_node
11970 ? gfc_build_addr_expr (NULL, stat) : stat);
11971 gfc_add_expr_to_block (&se.pre, tmp);
11972
11973 if (count2 != NULL_TREE)
11974 gfc_add_modify (&se.pre, count2,
11975 fold_convert (TREE_TYPE (count2), count));
11976
11977 if (stat2 != NULL_TREE)
11978 gfc_add_modify (&se.pre, stat2,
11979 fold_convert (TREE_TYPE (stat2), stat));
11980
11981 return gfc_finish_block (&se.pre);
11982 }
11983
11984 gfc_init_se (&argse, NULL);
11985 gfc_conv_expr_val (&argse, code->ext.actual->expr);
11986 gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
11987
11988 if (stat != NULL_TREE)
11989 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
11990
11991 return gfc_finish_block (&se.pre);
11992 }
11993
11994
11995 /* This is a peculiar case because of the need to do dependency checking.
11996 It is called via trans-stmt.c(gfc_trans_call), where it is picked out as
11997 a special case and this function called instead of
11998 gfc_conv_procedure_call. */
11999 void
gfc_conv_intrinsic_mvbits(gfc_se * se,gfc_actual_arglist * actual_args,gfc_loopinfo * loop)12000 gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
12001 gfc_loopinfo *loop)
12002 {
12003 gfc_actual_arglist *actual;
12004 gfc_se argse[5];
12005 gfc_expr *arg[5];
12006 gfc_ss *lss;
12007 int n;
12008
12009 tree from, frompos, len, to, topos;
12010 tree lenmask, oldbits, newbits, bitsize;
12011 tree type, utype, above, mask1, mask2;
12012
12013 if (loop)
12014 lss = loop->ss;
12015 else
12016 lss = gfc_ss_terminator;
12017
12018 actual = actual_args;
12019 for (n = 0; n < 5; n++, actual = actual->next)
12020 {
12021 arg[n] = actual->expr;
12022 gfc_init_se (&argse[n], NULL);
12023
12024 if (lss != gfc_ss_terminator)
12025 {
12026 gfc_copy_loopinfo_to_se (&argse[n], loop);
12027 /* Find the ss for the expression if it is there. */
12028 argse[n].ss = lss;
12029 gfc_mark_ss_chain_used (lss, 1);
12030 }
12031
12032 gfc_conv_expr (&argse[n], arg[n]);
12033
12034 if (loop)
12035 lss = argse[n].ss;
12036 }
12037
12038 from = argse[0].expr;
12039 frompos = argse[1].expr;
12040 len = argse[2].expr;
12041 to = argse[3].expr;
12042 topos = argse[4].expr;
12043
12044 /* The type of the result (TO). */
12045 type = TREE_TYPE (to);
12046 bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
12047
12048 /* Optionally generate code for runtime argument check. */
12049 if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
12050 {
12051 tree nbits, below, ccond;
12052 tree fp = fold_convert (long_integer_type_node, frompos);
12053 tree ln = fold_convert (long_integer_type_node, len);
12054 tree tp = fold_convert (long_integer_type_node, topos);
12055 below = fold_build2_loc (input_location, LT_EXPR,
12056 logical_type_node, frompos,
12057 build_int_cst (TREE_TYPE (frompos), 0));
12058 above = fold_build2_loc (input_location, GT_EXPR,
12059 logical_type_node, frompos,
12060 fold_convert (TREE_TYPE (frompos), bitsize));
12061 ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12062 logical_type_node, below, above);
12063 gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
12064 &arg[1]->where,
12065 "FROMPOS argument (%ld) out of range 0:%d "
12066 "in intrinsic MVBITS", fp, bitsize);
12067 below = fold_build2_loc (input_location, LT_EXPR,
12068 logical_type_node, len,
12069 build_int_cst (TREE_TYPE (len), 0));
12070 above = fold_build2_loc (input_location, GT_EXPR,
12071 logical_type_node, len,
12072 fold_convert (TREE_TYPE (len), bitsize));
12073 ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12074 logical_type_node, below, above);
12075 gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
12076 &arg[2]->where,
12077 "LEN argument (%ld) out of range 0:%d "
12078 "in intrinsic MVBITS", ln, bitsize);
12079 below = fold_build2_loc (input_location, LT_EXPR,
12080 logical_type_node, topos,
12081 build_int_cst (TREE_TYPE (topos), 0));
12082 above = fold_build2_loc (input_location, GT_EXPR,
12083 logical_type_node, topos,
12084 fold_convert (TREE_TYPE (topos), bitsize));
12085 ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12086 logical_type_node, below, above);
12087 gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
12088 &arg[4]->where,
12089 "TOPOS argument (%ld) out of range 0:%d "
12090 "in intrinsic MVBITS", tp, bitsize);
12091
12092 /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
12093 integers. Additions below cannot overflow. */
12094 nbits = fold_convert (long_integer_type_node, bitsize);
12095 above = fold_build2_loc (input_location, PLUS_EXPR,
12096 long_integer_type_node, fp, ln);
12097 ccond = fold_build2_loc (input_location, GT_EXPR,
12098 logical_type_node, above, nbits);
12099 gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
12100 &arg[1]->where,
12101 "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12102 "in intrinsic MVBITS", fp, ln, bitsize);
12103 above = fold_build2_loc (input_location, PLUS_EXPR,
12104 long_integer_type_node, tp, ln);
12105 ccond = fold_build2_loc (input_location, GT_EXPR,
12106 logical_type_node, above, nbits);
12107 gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
12108 &arg[4]->where,
12109 "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12110 "in intrinsic MVBITS", tp, ln, bitsize);
12111 }
12112
12113 for (n = 0; n < 5; n++)
12114 {
12115 gfc_add_block_to_block (&se->pre, &argse[n].pre);
12116 gfc_add_block_to_block (&se->post, &argse[n].post);
12117 }
12118
12119 /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
12120 above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
12121 len, fold_convert (TREE_TYPE (len), bitsize));
12122 mask1 = build_int_cst (type, -1);
12123 mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12124 build_int_cst (type, 1), len);
12125 mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
12126 mask2, build_int_cst (type, 1));
12127 lenmask = fold_build3_loc (input_location, COND_EXPR, type,
12128 above, mask1, mask2);
12129
12130 /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
12131 * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
12132 * not strictly necessary; artificial bits from rshift will be masked. */
12133 utype = unsigned_type_for (type);
12134 newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
12135 fold_convert (utype, from), frompos);
12136 newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
12137 fold_convert (type, newbits), lenmask);
12138 newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12139 newbits, topos);
12140
12141 /* oldbits = TO & (~(lenmask << TOPOS)). */
12142 oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12143 lenmask, topos);
12144 oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
12145 oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
12146
12147 /* TO = newbits | oldbits. */
12148 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
12149 oldbits, newbits);
12150
12151 /* Return the assignment. */
12152 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
12153 void_type_node, to, se->expr);
12154 }
12155
12156
12157 static tree
conv_intrinsic_move_alloc(gfc_code * code)12158 conv_intrinsic_move_alloc (gfc_code *code)
12159 {
12160 stmtblock_t block;
12161 gfc_expr *from_expr, *to_expr;
12162 gfc_expr *to_expr2, *from_expr2 = NULL;
12163 gfc_se from_se, to_se;
12164 tree tmp;
12165 bool coarray;
12166
12167 gfc_start_block (&block);
12168
12169 from_expr = code->ext.actual->expr;
12170 to_expr = code->ext.actual->next->expr;
12171
12172 gfc_init_se (&from_se, NULL);
12173 gfc_init_se (&to_se, NULL);
12174
12175 gcc_assert (from_expr->ts.type != BT_CLASS
12176 || to_expr->ts.type == BT_CLASS);
12177 coarray = gfc_get_corank (from_expr) != 0;
12178
12179 if (from_expr->rank == 0 && !coarray)
12180 {
12181 if (from_expr->ts.type != BT_CLASS)
12182 from_expr2 = from_expr;
12183 else
12184 {
12185 from_expr2 = gfc_copy_expr (from_expr);
12186 gfc_add_data_component (from_expr2);
12187 }
12188
12189 if (to_expr->ts.type != BT_CLASS)
12190 to_expr2 = to_expr;
12191 else
12192 {
12193 to_expr2 = gfc_copy_expr (to_expr);
12194 gfc_add_data_component (to_expr2);
12195 }
12196
12197 from_se.want_pointer = 1;
12198 to_se.want_pointer = 1;
12199 gfc_conv_expr (&from_se, from_expr2);
12200 gfc_conv_expr (&to_se, to_expr2);
12201 gfc_add_block_to_block (&block, &from_se.pre);
12202 gfc_add_block_to_block (&block, &to_se.pre);
12203
12204 /* Deallocate "to". */
12205 tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
12206 true, to_expr, to_expr->ts);
12207 gfc_add_expr_to_block (&block, tmp);
12208
12209 /* Assign (_data) pointers. */
12210 gfc_add_modify_loc (input_location, &block, to_se.expr,
12211 fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
12212
12213 /* Set "from" to NULL. */
12214 gfc_add_modify_loc (input_location, &block, from_se.expr,
12215 fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
12216
12217 gfc_add_block_to_block (&block, &from_se.post);
12218 gfc_add_block_to_block (&block, &to_se.post);
12219
12220 /* Set _vptr. */
12221 if (to_expr->ts.type == BT_CLASS)
12222 {
12223 gfc_symbol *vtab;
12224
12225 gfc_free_expr (to_expr2);
12226 gfc_init_se (&to_se, NULL);
12227 to_se.want_pointer = 1;
12228 gfc_add_vptr_component (to_expr);
12229 gfc_conv_expr (&to_se, to_expr);
12230
12231 if (from_expr->ts.type == BT_CLASS)
12232 {
12233 if (UNLIMITED_POLY (from_expr))
12234 vtab = NULL;
12235 else
12236 {
12237 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
12238 gcc_assert (vtab);
12239 }
12240
12241 gfc_free_expr (from_expr2);
12242 gfc_init_se (&from_se, NULL);
12243 from_se.want_pointer = 1;
12244 gfc_add_vptr_component (from_expr);
12245 gfc_conv_expr (&from_se, from_expr);
12246 gfc_add_modify_loc (input_location, &block, to_se.expr,
12247 fold_convert (TREE_TYPE (to_se.expr),
12248 from_se.expr));
12249
12250 /* Reset _vptr component to declared type. */
12251 if (vtab == NULL)
12252 /* Unlimited polymorphic. */
12253 gfc_add_modify_loc (input_location, &block, from_se.expr,
12254 fold_convert (TREE_TYPE (from_se.expr),
12255 null_pointer_node));
12256 else
12257 {
12258 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12259 gfc_add_modify_loc (input_location, &block, from_se.expr,
12260 fold_convert (TREE_TYPE (from_se.expr), tmp));
12261 }
12262 }
12263 else
12264 {
12265 vtab = gfc_find_vtab (&from_expr->ts);
12266 gcc_assert (vtab);
12267 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12268 gfc_add_modify_loc (input_location, &block, to_se.expr,
12269 fold_convert (TREE_TYPE (to_se.expr), tmp));
12270 }
12271 }
12272
12273 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
12274 {
12275 gfc_add_modify_loc (input_location, &block, to_se.string_length,
12276 fold_convert (TREE_TYPE (to_se.string_length),
12277 from_se.string_length));
12278 if (from_expr->ts.deferred)
12279 gfc_add_modify_loc (input_location, &block, from_se.string_length,
12280 build_int_cst (TREE_TYPE (from_se.string_length), 0));
12281 }
12282
12283 return gfc_finish_block (&block);
12284 }
12285
12286 /* Update _vptr component. */
12287 if (to_expr->ts.type == BT_CLASS)
12288 {
12289 gfc_symbol *vtab;
12290
12291 to_se.want_pointer = 1;
12292 to_expr2 = gfc_copy_expr (to_expr);
12293 gfc_add_vptr_component (to_expr2);
12294 gfc_conv_expr (&to_se, to_expr2);
12295
12296 if (from_expr->ts.type == BT_CLASS)
12297 {
12298 if (UNLIMITED_POLY (from_expr))
12299 vtab = NULL;
12300 else
12301 {
12302 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
12303 gcc_assert (vtab);
12304 }
12305
12306 from_se.want_pointer = 1;
12307 from_expr2 = gfc_copy_expr (from_expr);
12308 gfc_add_vptr_component (from_expr2);
12309 gfc_conv_expr (&from_se, from_expr2);
12310 gfc_add_modify_loc (input_location, &block, to_se.expr,
12311 fold_convert (TREE_TYPE (to_se.expr),
12312 from_se.expr));
12313
12314 /* Reset _vptr component to declared type. */
12315 if (vtab == NULL)
12316 /* Unlimited polymorphic. */
12317 gfc_add_modify_loc (input_location, &block, from_se.expr,
12318 fold_convert (TREE_TYPE (from_se.expr),
12319 null_pointer_node));
12320 else
12321 {
12322 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12323 gfc_add_modify_loc (input_location, &block, from_se.expr,
12324 fold_convert (TREE_TYPE (from_se.expr), tmp));
12325 }
12326 }
12327 else
12328 {
12329 vtab = gfc_find_vtab (&from_expr->ts);
12330 gcc_assert (vtab);
12331 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12332 gfc_add_modify_loc (input_location, &block, to_se.expr,
12333 fold_convert (TREE_TYPE (to_se.expr), tmp));
12334 }
12335
12336 gfc_free_expr (to_expr2);
12337 gfc_init_se (&to_se, NULL);
12338
12339 if (from_expr->ts.type == BT_CLASS)
12340 {
12341 gfc_free_expr (from_expr2);
12342 gfc_init_se (&from_se, NULL);
12343 }
12344 }
12345
12346
12347 /* Deallocate "to". */
12348 if (from_expr->rank == 0)
12349 {
12350 to_se.want_coarray = 1;
12351 from_se.want_coarray = 1;
12352 }
12353 gfc_conv_expr_descriptor (&to_se, to_expr);
12354 gfc_conv_expr_descriptor (&from_se, from_expr);
12355
12356 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
12357 is an image control "statement", cf. IR F08/0040 in 12-006A. */
12358 if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
12359 {
12360 tree cond;
12361
12362 tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
12363 NULL_TREE, NULL_TREE, true, to_expr,
12364 GFC_CAF_COARRAY_DEALLOCATE_ONLY);
12365 gfc_add_expr_to_block (&block, tmp);
12366
12367 tmp = gfc_conv_descriptor_data_get (to_se.expr);
12368 cond = fold_build2_loc (input_location, EQ_EXPR,
12369 logical_type_node, tmp,
12370 fold_convert (TREE_TYPE (tmp),
12371 null_pointer_node));
12372 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
12373 3, null_pointer_node, null_pointer_node,
12374 build_int_cst (integer_type_node, 0));
12375
12376 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
12377 tmp, build_empty_stmt (input_location));
12378 gfc_add_expr_to_block (&block, tmp);
12379 }
12380 else
12381 {
12382 if (to_expr->ts.type == BT_DERIVED
12383 && to_expr->ts.u.derived->attr.alloc_comp)
12384 {
12385 tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
12386 to_se.expr, to_expr->rank);
12387 gfc_add_expr_to_block (&block, tmp);
12388 }
12389
12390 tmp = gfc_conv_descriptor_data_get (to_se.expr);
12391 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
12392 NULL_TREE, true, to_expr,
12393 GFC_CAF_COARRAY_NOCOARRAY);
12394 gfc_add_expr_to_block (&block, tmp);
12395 }
12396
12397 /* Move the pointer and update the array descriptor data. */
12398 gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
12399
12400 /* Set "from" to NULL. */
12401 tmp = gfc_conv_descriptor_data_get (from_se.expr);
12402 gfc_add_modify_loc (input_location, &block, tmp,
12403 fold_convert (TREE_TYPE (tmp), null_pointer_node));
12404
12405
12406 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
12407 {
12408 gfc_add_modify_loc (input_location, &block, to_se.string_length,
12409 fold_convert (TREE_TYPE (to_se.string_length),
12410 from_se.string_length));
12411 if (from_expr->ts.deferred)
12412 gfc_add_modify_loc (input_location, &block, from_se.string_length,
12413 build_int_cst (TREE_TYPE (from_se.string_length), 0));
12414 }
12415
12416 return gfc_finish_block (&block);
12417 }
12418
12419
12420 tree
gfc_conv_intrinsic_subroutine(gfc_code * code)12421 gfc_conv_intrinsic_subroutine (gfc_code *code)
12422 {
12423 tree res;
12424
12425 gcc_assert (code->resolved_isym);
12426
12427 switch (code->resolved_isym->id)
12428 {
12429 case GFC_ISYM_MOVE_ALLOC:
12430 res = conv_intrinsic_move_alloc (code);
12431 break;
12432
12433 case GFC_ISYM_ATOMIC_CAS:
12434 res = conv_intrinsic_atomic_cas (code);
12435 break;
12436
12437 case GFC_ISYM_ATOMIC_ADD:
12438 case GFC_ISYM_ATOMIC_AND:
12439 case GFC_ISYM_ATOMIC_DEF:
12440 case GFC_ISYM_ATOMIC_OR:
12441 case GFC_ISYM_ATOMIC_XOR:
12442 case GFC_ISYM_ATOMIC_FETCH_ADD:
12443 case GFC_ISYM_ATOMIC_FETCH_AND:
12444 case GFC_ISYM_ATOMIC_FETCH_OR:
12445 case GFC_ISYM_ATOMIC_FETCH_XOR:
12446 res = conv_intrinsic_atomic_op (code);
12447 break;
12448
12449 case GFC_ISYM_ATOMIC_REF:
12450 res = conv_intrinsic_atomic_ref (code);
12451 break;
12452
12453 case GFC_ISYM_EVENT_QUERY:
12454 res = conv_intrinsic_event_query (code);
12455 break;
12456
12457 case GFC_ISYM_C_F_POINTER:
12458 case GFC_ISYM_C_F_PROCPOINTER:
12459 res = conv_isocbinding_subroutine (code);
12460 break;
12461
12462 case GFC_ISYM_CAF_SEND:
12463 res = conv_caf_send (code);
12464 break;
12465
12466 case GFC_ISYM_CO_BROADCAST:
12467 case GFC_ISYM_CO_MIN:
12468 case GFC_ISYM_CO_MAX:
12469 case GFC_ISYM_CO_REDUCE:
12470 case GFC_ISYM_CO_SUM:
12471 res = conv_co_collective (code);
12472 break;
12473
12474 case GFC_ISYM_FREE:
12475 res = conv_intrinsic_free (code);
12476 break;
12477
12478 case GFC_ISYM_RANDOM_INIT:
12479 res = conv_intrinsic_random_init (code);
12480 break;
12481
12482 case GFC_ISYM_KILL:
12483 res = conv_intrinsic_kill_sub (code);
12484 break;
12485
12486 case GFC_ISYM_MVBITS:
12487 res = NULL_TREE;
12488 break;
12489
12490 case GFC_ISYM_SYSTEM_CLOCK:
12491 res = conv_intrinsic_system_clock (code);
12492 break;
12493
12494 default:
12495 res = NULL_TREE;
12496 break;
12497 }
12498
12499 return res;
12500 }
12501
12502 #include "gt-fortran-trans-intrinsic.h"
12503