Line data Source code
1 : /* Intrinsic translation
2 : Copyright (C) 2002-2026 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.cc-- 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 : #include "realmpfr.h"
45 : #include "constructor.h"
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
144 11454 : builtin_decl_for_precision (enum built_in_function base_built_in,
145 : int precision)
146 : {
147 11454 : enum built_in_function i = END_BUILTINS;
148 :
149 11454 : gfc_intrinsic_map_t *m;
150 490551 : for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
151 : ;
152 :
153 11454 : if (precision == TYPE_PRECISION (float_type_node))
154 5814 : i = m->float_built_in;
155 5640 : else if (precision == TYPE_PRECISION (double_type_node))
156 : i = m->double_built_in;
157 1695 : else if (precision == TYPE_PRECISION (long_double_type_node)
158 1695 : && (!gfc_real16_is_float128
159 1571 : || long_double_type_node != gfc_float128_type_node))
160 1571 : i = m->long_double_built_in;
161 124 : else if (precision == TYPE_PRECISION (gfc_float128_type_node))
162 : {
163 : /* Special treatment, because it is not exactly a built-in, but
164 : a library function. */
165 124 : return m->real16_decl;
166 : }
167 :
168 11330 : return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
169 : }
170 :
171 :
172 : tree
173 10415 : gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
174 : int kind)
175 : {
176 10415 : int i = gfc_validate_kind (BT_REAL, kind, false);
177 :
178 10415 : if (gfc_real_kinds[i].c_float128)
179 : {
180 : /* For _Float128, the story is a bit different, because we return
181 : a decl to a library function rather than a built-in. */
182 : gfc_intrinsic_map_t *m;
183 36328 : for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
184 : ;
185 :
186 905 : return m->real16_decl;
187 : }
188 :
189 9510 : return builtin_decl_for_precision (double_built_in,
190 9510 : gfc_real_kinds[i].mode_precision);
191 : }
192 :
193 :
194 : /* Evaluate the arguments to an intrinsic function. The value
195 : of NARGS may be less than the actual number of arguments in EXPR
196 : to allow optional "KIND" arguments that are not included in the
197 : generated code to be ignored. */
198 :
199 : static void
200 81243 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
201 : tree *argarray, int nargs)
202 : {
203 81243 : gfc_actual_arglist *actual;
204 81243 : gfc_expr *e;
205 81243 : gfc_intrinsic_arg *formal;
206 81243 : gfc_se argse;
207 81243 : int curr_arg;
208 :
209 81243 : formal = expr->value.function.isym->formal;
210 81243 : actual = expr->value.function.actual;
211 :
212 183130 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
213 63240 : actual = actual->next,
214 101887 : formal = formal ? formal->next : NULL)
215 : {
216 101887 : gcc_assert (actual);
217 101887 : e = actual->expr;
218 : /* Skip omitted optional arguments. */
219 101887 : if (!e)
220 : {
221 31 : --curr_arg;
222 31 : continue;
223 : }
224 :
225 : /* Evaluate the parameter. This will substitute scalarized
226 : references automatically. */
227 101856 : gfc_init_se (&argse, se);
228 :
229 101856 : if (e->ts.type == BT_CHARACTER)
230 : {
231 9623 : gfc_conv_expr (&argse, e);
232 9623 : gfc_conv_string_parameter (&argse);
233 9623 : argarray[curr_arg++] = argse.string_length;
234 9623 : gcc_assert (curr_arg < nargs);
235 : }
236 : else
237 92233 : gfc_conv_expr_val (&argse, e);
238 :
239 : /* If an optional argument is itself an optional dummy argument,
240 : check its presence and substitute a null if absent. */
241 101856 : if (e->expr_type == EXPR_VARIABLE
242 51914 : && e->symtree->n.sym->attr.optional
243 203 : && formal
244 153 : && formal->optional)
245 80 : gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
246 :
247 101856 : gfc_add_block_to_block (&se->pre, &argse.pre);
248 101856 : gfc_add_block_to_block (&se->post, &argse.post);
249 101856 : argarray[curr_arg] = argse.expr;
250 : }
251 81243 : }
252 :
253 : /* Count the number of actual arguments to the intrinsic function EXPR
254 : including any "hidden" string length arguments. */
255 :
256 : static unsigned int
257 56197 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
258 : {
259 56197 : int n = 0;
260 56197 : gfc_actual_arglist *actual;
261 :
262 127623 : for (actual = expr->value.function.actual; actual; actual = actual->next)
263 : {
264 71426 : if (!actual->expr)
265 6358 : continue;
266 :
267 65068 : if (actual->expr->ts.type == BT_CHARACTER)
268 4549 : n += 2;
269 : else
270 60519 : n++;
271 : }
272 :
273 56197 : return n;
274 : }
275 :
276 :
277 : /* Conversions between different types are output by the frontend as
278 : intrinsic functions. We implement these directly with inline code. */
279 :
280 : static void
281 40075 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
282 : {
283 40075 : tree type;
284 40075 : tree *args;
285 40075 : int nargs;
286 :
287 40075 : nargs = gfc_intrinsic_argument_list_length (expr);
288 40075 : args = XALLOCAVEC (tree, nargs);
289 :
290 : /* Evaluate all the arguments passed. Whilst we're only interested in the
291 : first one here, there are other parts of the front-end that assume this
292 : and will trigger an ICE if it's not the case. */
293 40075 : type = gfc_typenode_for_spec (&expr->ts);
294 40075 : gcc_assert (expr->value.function.actual->expr);
295 40075 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
296 :
297 : /* Conversion between character kinds involves a call to a library
298 : function. */
299 40075 : if (expr->ts.type == BT_CHARACTER)
300 : {
301 248 : tree fndecl, var, addr, tmp;
302 :
303 248 : if (expr->ts.kind == 1
304 97 : && expr->value.function.actual->expr->ts.kind == 4)
305 97 : fndecl = gfor_fndecl_convert_char4_to_char1;
306 151 : else if (expr->ts.kind == 4
307 151 : && expr->value.function.actual->expr->ts.kind == 1)
308 151 : fndecl = gfor_fndecl_convert_char1_to_char4;
309 : else
310 0 : gcc_unreachable ();
311 :
312 : /* Create the variable storing the converted value. */
313 248 : type = gfc_get_pchar_type (expr->ts.kind);
314 248 : var = gfc_create_var (type, "str");
315 248 : addr = gfc_build_addr_expr (build_pointer_type (type), var);
316 :
317 : /* Call the library function that will perform the conversion. */
318 248 : gcc_assert (nargs >= 2);
319 248 : tmp = build_call_expr_loc (input_location,
320 : fndecl, 3, addr, args[0], args[1]);
321 248 : gfc_add_expr_to_block (&se->pre, tmp);
322 :
323 : /* Free the temporary afterwards. */
324 248 : tmp = gfc_call_free (var);
325 248 : gfc_add_expr_to_block (&se->post, tmp);
326 :
327 248 : se->expr = var;
328 248 : se->string_length = args[0];
329 :
330 248 : return;
331 : }
332 :
333 : /* Conversion from complex to non-complex involves taking the real
334 : component of the value. */
335 39827 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
336 39827 : && expr->ts.type != BT_COMPLEX)
337 : {
338 583 : tree artype;
339 :
340 583 : artype = TREE_TYPE (TREE_TYPE (args[0]));
341 583 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
342 : args[0]);
343 : }
344 :
345 39827 : se->expr = convert (type, args[0]);
346 : }
347 :
348 : /* This is needed because the gcc backend only implements
349 : FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
350 : FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
351 : Similarly for CEILING. */
352 :
353 : static tree
354 132 : build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
355 : {
356 132 : tree tmp;
357 132 : tree cond;
358 132 : tree argtype;
359 132 : tree intval;
360 :
361 132 : argtype = TREE_TYPE (arg);
362 132 : arg = gfc_evaluate_now (arg, pblock);
363 :
364 132 : intval = convert (type, arg);
365 132 : intval = gfc_evaluate_now (intval, pblock);
366 :
367 132 : tmp = convert (argtype, intval);
368 248 : cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
369 : logical_type_node, tmp, arg);
370 :
371 248 : tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
372 : intval, build_int_cst (type, 1));
373 132 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
374 132 : return tmp;
375 : }
376 :
377 :
378 : /* Round to nearest integer, away from zero. */
379 :
380 : static tree
381 516 : build_round_expr (tree arg, tree restype)
382 : {
383 516 : tree argtype;
384 516 : tree fn;
385 516 : int argprec, resprec;
386 :
387 516 : argtype = TREE_TYPE (arg);
388 516 : argprec = TYPE_PRECISION (argtype);
389 516 : resprec = TYPE_PRECISION (restype);
390 :
391 : /* Depending on the type of the result, choose the int intrinsic (iround,
392 : available only as a builtin, therefore cannot use it for _Float128), long
393 : int intrinsic (lround family) or long long intrinsic (llround). If we
394 : don't have an appropriate function that converts directly to the integer
395 : type (such as kind == 16), just use ROUND, and then convert the result to
396 : an integer. We might also need to convert the result afterwards. */
397 516 : if (resprec <= INT_TYPE_SIZE
398 516 : && argprec <= TYPE_PRECISION (long_double_type_node))
399 458 : fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
400 62 : else if (resprec <= LONG_TYPE_SIZE)
401 46 : fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
402 12 : else if (resprec <= LONG_LONG_TYPE_SIZE)
403 0 : fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
404 12 : else if (resprec >= argprec)
405 12 : fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec);
406 : else
407 0 : gcc_unreachable ();
408 :
409 516 : return convert (restype, build_call_expr_loc (input_location,
410 516 : fn, 1, arg));
411 : }
412 :
413 :
414 : /* Convert a real to an integer using a specific rounding mode.
415 : Ideally we would just build the corresponding GENERIC node,
416 : however the RTL expander only actually supports FIX_TRUNC_EXPR. */
417 :
418 : static tree
419 1603 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
420 : enum rounding_mode op)
421 : {
422 1603 : switch (op)
423 : {
424 116 : case RND_FLOOR:
425 116 : return build_fixbound_expr (pblock, arg, type, 0);
426 :
427 16 : case RND_CEIL:
428 16 : return build_fixbound_expr (pblock, arg, type, 1);
429 :
430 162 : case RND_ROUND:
431 162 : return build_round_expr (arg, type);
432 :
433 1309 : case RND_TRUNC:
434 1309 : return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
435 :
436 0 : default:
437 0 : gcc_unreachable ();
438 : }
439 : }
440 :
441 :
442 : /* Round a real value using the specified rounding mode.
443 : We use a temporary integer of that same kind size as the result.
444 : Values larger than those that can be represented by this kind are
445 : unchanged, as they will not be accurate enough to represent the
446 : rounding.
447 : huge = HUGE (KIND (a))
448 : aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449 : */
450 :
451 : static void
452 220 : gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
453 : {
454 220 : tree type;
455 220 : tree itype;
456 220 : tree arg[2];
457 220 : tree tmp;
458 220 : tree cond;
459 220 : tree decl;
460 220 : mpfr_t huge;
461 220 : int n, nargs;
462 220 : int kind;
463 :
464 220 : kind = expr->ts.kind;
465 220 : nargs = gfc_intrinsic_argument_list_length (expr);
466 :
467 220 : decl = NULL_TREE;
468 : /* We have builtin functions for some cases. */
469 220 : switch (op)
470 : {
471 74 : case RND_ROUND:
472 74 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
473 74 : break;
474 :
475 146 : case RND_TRUNC:
476 146 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
477 146 : break;
478 :
479 0 : default:
480 0 : gcc_unreachable ();
481 : }
482 :
483 : /* Evaluate the argument. */
484 220 : gcc_assert (expr->value.function.actual->expr);
485 220 : gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
486 :
487 : /* Use a builtin function if one exists. */
488 220 : if (decl != NULL_TREE)
489 : {
490 220 : se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
491 220 : return;
492 : }
493 :
494 : /* This code is probably redundant, but we'll keep it lying around just
495 : in case. */
496 0 : type = gfc_typenode_for_spec (&expr->ts);
497 0 : arg[0] = gfc_evaluate_now (arg[0], &se->pre);
498 :
499 : /* Test if the value is too large to handle sensibly. */
500 0 : gfc_set_model_kind (kind);
501 0 : mpfr_init (huge);
502 0 : n = gfc_validate_kind (BT_INTEGER, kind, false);
503 0 : mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
504 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
505 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
506 : tmp);
507 :
508 0 : mpfr_neg (huge, huge, GFC_RND_MODE);
509 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
510 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
511 : tmp);
512 0 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
513 : cond, tmp);
514 0 : itype = gfc_get_int_type (kind);
515 :
516 0 : tmp = build_fix_expr (&se->pre, arg[0], itype, op);
517 0 : tmp = convert (type, tmp);
518 0 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
519 : arg[0]);
520 0 : mpfr_clear (huge);
521 : }
522 :
523 :
524 : /* Convert to an integer using the specified rounding mode. */
525 :
526 : static void
527 3130 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
528 : {
529 3130 : tree type;
530 3130 : tree *args;
531 3130 : int nargs;
532 :
533 3130 : nargs = gfc_intrinsic_argument_list_length (expr);
534 3130 : args = XALLOCAVEC (tree, nargs);
535 :
536 : /* Evaluate the argument, we process all arguments even though we only
537 : use the first one for code generation purposes. */
538 3130 : type = gfc_typenode_for_spec (&expr->ts);
539 3130 : gcc_assert (expr->value.function.actual->expr);
540 3130 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
541 :
542 3130 : if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
543 : {
544 : /* Conversion to a different integer kind. */
545 1527 : se->expr = convert (type, args[0]);
546 : }
547 : else
548 : {
549 : /* Conversion from complex to non-complex involves taking the real
550 : component of the value. */
551 1603 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
552 1603 : && expr->ts.type != BT_COMPLEX)
553 : {
554 192 : tree artype;
555 :
556 192 : artype = TREE_TYPE (TREE_TYPE (args[0]));
557 192 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
558 : args[0]);
559 : }
560 :
561 1603 : se->expr = build_fix_expr (&se->pre, args[0], type, op);
562 : }
563 3130 : }
564 :
565 :
566 : /* Get the imaginary component of a value. */
567 :
568 : static void
569 440 : gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
570 : {
571 440 : tree arg;
572 :
573 440 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
574 440 : se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
575 440 : TREE_TYPE (TREE_TYPE (arg)), arg);
576 440 : }
577 :
578 :
579 : /* Get the complex conjugate of a value. */
580 :
581 : static void
582 257 : gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
583 : {
584 257 : tree arg;
585 :
586 257 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
587 257 : se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
588 257 : }
589 :
590 :
591 :
592 : static tree
593 667086 : define_quad_builtin (const char *name, tree type, bool is_const)
594 : {
595 667086 : tree fndecl;
596 667086 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
597 : type);
598 :
599 : /* Mark the decl as external. */
600 667086 : DECL_EXTERNAL (fndecl) = 1;
601 667086 : TREE_PUBLIC (fndecl) = 1;
602 :
603 : /* Mark it __attribute__((const)). */
604 667086 : TREE_READONLY (fndecl) = is_const;
605 :
606 667086 : rest_of_decl_compilation (fndecl, 1, 0);
607 :
608 667086 : return fndecl;
609 : }
610 :
611 : /* Add SIMD attribute for FNDECL built-in if the built-in
612 : name is in VECTORIZED_BUILTINS. */
613 :
614 : static void
615 45585760 : add_simd_flag_for_built_in (tree fndecl)
616 : {
617 45585760 : if (gfc_vectorized_builtins == NULL
618 18322450 : || fndecl == NULL_TREE)
619 37666735 : return;
620 :
621 7919025 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
622 7919025 : int *clauses = gfc_vectorized_builtins->get (name);
623 7919025 : if (clauses)
624 : {
625 4968188 : for (unsigned i = 0; i < 3; i++)
626 3726141 : if (*clauses & (1 << i))
627 : {
628 1242052 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
629 1242052 : tree omp_clause = NULL_TREE;
630 1242052 : if (simd_type == SIMD_NONE)
631 : ; /* No SIMD clause. */
632 : else
633 : {
634 1242052 : omp_clause_code code
635 : = (simd_type == SIMD_INBRANCH
636 1242052 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
637 1242052 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
638 1242052 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
639 : }
640 :
641 1242052 : DECL_ATTRIBUTES (fndecl)
642 2484104 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
643 1242052 : DECL_ATTRIBUTES (fndecl));
644 : }
645 : }
646 : }
647 :
648 : /* Set SIMD attribute to all built-in functions that are mentioned
649 : in gfc_vectorized_builtins vector. */
650 :
651 : void
652 77264 : gfc_adjust_builtins (void)
653 : {
654 77264 : gfc_intrinsic_map_t *m;
655 4635840 : for (m = gfc_intrinsic_map;
656 4635840 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
657 : {
658 4558576 : add_simd_flag_for_built_in (m->real4_decl);
659 4558576 : add_simd_flag_for_built_in (m->complex4_decl);
660 4558576 : add_simd_flag_for_built_in (m->real8_decl);
661 4558576 : add_simd_flag_for_built_in (m->complex8_decl);
662 4558576 : add_simd_flag_for_built_in (m->real10_decl);
663 4558576 : add_simd_flag_for_built_in (m->complex10_decl);
664 4558576 : add_simd_flag_for_built_in (m->real16_decl);
665 4558576 : add_simd_flag_for_built_in (m->complex16_decl);
666 4558576 : add_simd_flag_for_built_in (m->real16_decl);
667 4558576 : add_simd_flag_for_built_in (m->complex16_decl);
668 : }
669 :
670 : /* Release all strings. */
671 77264 : if (gfc_vectorized_builtins != NULL)
672 : {
673 1707816 : for (hash_map<nofree_string_hash, int>::iterator it
674 31055 : = gfc_vectorized_builtins->begin ();
675 1707816 : it != gfc_vectorized_builtins->end (); ++it)
676 1676761 : free (const_cast<char *> ((*it).first));
677 :
678 62110 : delete gfc_vectorized_builtins;
679 31055 : gfc_vectorized_builtins = NULL;
680 : }
681 77264 : }
682 :
683 : /* Initialize function decls for library functions. The external functions
684 : are created as required. Builtin functions are added here. */
685 :
686 : void
687 31766 : gfc_build_intrinsic_lib_fndecls (void)
688 : {
689 31766 : gfc_intrinsic_map_t *m;
690 31766 : tree quad_decls[END_BUILTINS + 1];
691 :
692 31766 : if (gfc_real16_is_float128)
693 : {
694 : /* If we have soft-float types, we create the decls for their
695 : C99-like library functions. For now, we only handle _Float128
696 : q-suffixed or IEC 60559 f128-suffixed functions. */
697 :
698 31766 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
699 31766 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
700 :
701 31766 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
702 :
703 31766 : type = gfc_float128_type_node;
704 31766 : complex_type = gfc_complex_float128_type_node;
705 : /* type (*) (type) */
706 31766 : func_1 = build_function_type_list (type, type, NULL_TREE);
707 : /* int (*) (type) */
708 31766 : func_iround = build_function_type_list (integer_type_node,
709 : type, NULL_TREE);
710 : /* long (*) (type) */
711 31766 : func_lround = build_function_type_list (long_integer_type_node,
712 : type, NULL_TREE);
713 : /* long long (*) (type) */
714 31766 : func_llround = build_function_type_list (long_long_integer_type_node,
715 : type, NULL_TREE);
716 : /* type (*) (type, type) */
717 31766 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
718 : /* type (*) (type, type, type) */
719 31766 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
720 : /* type (*) (type, &int) */
721 31766 : func_frexp
722 31766 : = build_function_type_list (type,
723 : type,
724 : build_pointer_type (integer_type_node),
725 : NULL_TREE);
726 : /* type (*) (type, int) */
727 31766 : func_scalbn = build_function_type_list (type,
728 : type, integer_type_node, NULL_TREE);
729 : /* type (*) (complex type) */
730 31766 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
731 : /* complex type (*) (complex type, complex type) */
732 31766 : func_cpow
733 31766 : = build_function_type_list (complex_type,
734 : complex_type, complex_type, NULL_TREE);
735 :
736 : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
737 : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
738 : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
739 :
740 : /* Only these built-ins are actually needed here. These are used directly
741 : from the code, when calling builtin_decl_for_precision() or
742 : builtin_decl_for_float_type(). The others are all constructed by
743 : gfc_get_intrinsic_lib_fndecl(). */
744 : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
745 : quad_decls[BUILT_IN_ ## ID] \
746 : = define_quad_builtin (gfc_real16_use_iec_60559 \
747 : ? NAME "f128" : NAME "q", func_ ## TYPE, \
748 : CONST);
749 :
750 : #include "mathbuiltins.def"
751 :
752 : #undef OTHER_BUILTIN
753 : #undef LIB_FUNCTION
754 : #undef DEFINE_MATH_BUILTIN
755 : #undef DEFINE_MATH_BUILTIN_C
756 :
757 : /* There is one built-in we defined manually, because it gets called
758 : with builtin_decl_for_precision() or builtin_decl_for_float_type()
759 : even though it is not an OTHER_BUILTIN: it is SQRT. */
760 31766 : quad_decls[BUILT_IN_SQRT]
761 31766 : = define_quad_builtin (gfc_real16_use_iec_60559
762 : ? "sqrtf128" : "sqrtq", func_1, true);
763 : }
764 :
765 : /* Add GCC builtin functions. */
766 1874194 : for (m = gfc_intrinsic_map;
767 1905960 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
768 : {
769 1874194 : if (m->float_built_in != END_BUILTINS)
770 1747130 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
771 1874194 : if (m->complex_float_built_in != END_BUILTINS)
772 508256 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
773 1874194 : if (m->double_built_in != END_BUILTINS)
774 1747130 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
775 1874194 : if (m->complex_double_built_in != END_BUILTINS)
776 508256 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
777 :
778 : /* If real(kind=10) exists, it is always long double. */
779 1874194 : if (m->long_double_built_in != END_BUILTINS)
780 1747130 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
781 1874194 : if (m->complex_long_double_built_in != END_BUILTINS)
782 508256 : m->complex10_decl
783 508256 : = builtin_decl_explicit (m->complex_long_double_built_in);
784 :
785 1874194 : if (!gfc_real16_is_float128)
786 : {
787 0 : if (m->long_double_built_in != END_BUILTINS)
788 0 : m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
789 0 : if (m->complex_long_double_built_in != END_BUILTINS)
790 0 : m->complex16_decl
791 0 : = builtin_decl_explicit (m->complex_long_double_built_in);
792 : }
793 1874194 : else if (quad_decls[m->double_built_in] != NULL_TREE)
794 : {
795 : /* Quad-precision function calls are constructed when first
796 : needed by builtin_decl_for_precision(), except for those
797 : that will be used directly (define by OTHER_BUILTIN). */
798 667086 : m->real16_decl = quad_decls[m->double_built_in];
799 : }
800 1207108 : else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
801 : {
802 : /* Same thing for the complex ones. */
803 0 : m->complex16_decl = quad_decls[m->double_built_in];
804 : }
805 : }
806 31766 : }
807 :
808 :
809 : /* Create a fndecl for a simple intrinsic library function. */
810 :
811 : static tree
812 4420 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
813 : {
814 4420 : tree type;
815 4420 : vec<tree, va_gc> *argtypes;
816 4420 : tree fndecl;
817 4420 : gfc_actual_arglist *actual;
818 4420 : tree *pdecl;
819 4420 : gfc_typespec *ts;
820 4420 : char name[GFC_MAX_SYMBOL_LEN + 3];
821 :
822 4420 : ts = &expr->ts;
823 4420 : if (ts->type == BT_REAL)
824 : {
825 3558 : switch (ts->kind)
826 : {
827 1273 : case 4:
828 1273 : pdecl = &m->real4_decl;
829 1273 : break;
830 1272 : case 8:
831 1272 : pdecl = &m->real8_decl;
832 1272 : break;
833 571 : case 10:
834 571 : pdecl = &m->real10_decl;
835 571 : break;
836 442 : case 16:
837 442 : pdecl = &m->real16_decl;
838 442 : break;
839 0 : default:
840 0 : gcc_unreachable ();
841 : }
842 : }
843 862 : else if (ts->type == BT_COMPLEX)
844 : {
845 862 : gcc_assert (m->complex_available);
846 :
847 862 : switch (ts->kind)
848 : {
849 386 : case 4:
850 386 : pdecl = &m->complex4_decl;
851 386 : break;
852 405 : case 8:
853 405 : pdecl = &m->complex8_decl;
854 405 : break;
855 51 : case 10:
856 51 : pdecl = &m->complex10_decl;
857 51 : break;
858 20 : case 16:
859 20 : pdecl = &m->complex16_decl;
860 20 : break;
861 0 : default:
862 0 : gcc_unreachable ();
863 : }
864 : }
865 : else
866 0 : gcc_unreachable ();
867 :
868 4420 : if (*pdecl)
869 4081 : return *pdecl;
870 :
871 339 : if (m->libm_name)
872 : {
873 162 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
874 162 : if (gfc_real_kinds[n].c_float)
875 0 : snprintf (name, sizeof (name), "%s%s%s",
876 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
877 162 : else if (gfc_real_kinds[n].c_double)
878 0 : snprintf (name, sizeof (name), "%s%s",
879 0 : ts->type == BT_COMPLEX ? "c" : "", m->name);
880 162 : else if (gfc_real_kinds[n].c_long_double)
881 0 : snprintf (name, sizeof (name), "%s%s%s",
882 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
883 162 : else if (gfc_real_kinds[n].c_float128)
884 162 : snprintf (name, sizeof (name), "%s%s%s",
885 162 : ts->type == BT_COMPLEX ? "c" : "", m->name,
886 162 : gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
887 : else
888 0 : gcc_unreachable ();
889 : }
890 : else
891 : {
892 354 : snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
893 177 : ts->type == BT_COMPLEX ? 'c' : 'r',
894 : gfc_type_abi_kind (ts));
895 : }
896 :
897 339 : argtypes = NULL;
898 694 : for (actual = expr->value.function.actual; actual; actual = actual->next)
899 : {
900 355 : type = gfc_typenode_for_spec (&actual->expr->ts);
901 355 : vec_safe_push (argtypes, type);
902 : }
903 1017 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
904 339 : fndecl = build_decl (input_location,
905 : FUNCTION_DECL, get_identifier (name), type);
906 :
907 : /* Mark the decl as external. */
908 339 : DECL_EXTERNAL (fndecl) = 1;
909 339 : TREE_PUBLIC (fndecl) = 1;
910 :
911 : /* Mark it __attribute__((const)), if possible. */
912 339 : TREE_READONLY (fndecl) = m->is_constant;
913 :
914 339 : rest_of_decl_compilation (fndecl, 1, 0);
915 :
916 339 : (*pdecl) = fndecl;
917 339 : return fndecl;
918 : }
919 :
920 :
921 : /* Convert an intrinsic function into an external or builtin call. */
922 :
923 : static void
924 3874 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
925 : {
926 3874 : gfc_intrinsic_map_t *m;
927 3874 : tree fndecl;
928 3874 : tree rettype;
929 3874 : tree *args;
930 3874 : unsigned int num_args;
931 3874 : gfc_isym_id id;
932 :
933 3874 : id = expr->value.function.isym->id;
934 : /* Find the entry for this function. */
935 79655 : for (m = gfc_intrinsic_map;
936 79655 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
937 : {
938 79655 : if (id == m->id)
939 : break;
940 : }
941 :
942 3874 : if (m->id == GFC_ISYM_NONE)
943 : {
944 0 : 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 3874 : num_args = gfc_intrinsic_argument_list_length (expr);
950 3874 : args = XALLOCAVEC (tree, num_args);
951 :
952 3874 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
953 3874 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
954 3874 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
955 :
956 3874 : fndecl = build_addr (fndecl);
957 3874 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
958 3874 : }
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
966 1550 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
967 : tree a, tree b, stmtblock_t* target)
968 : {
969 1550 : tree cond;
970 1550 : tree name;
971 :
972 : /* If bounds-checking is disabled, do nothing. */
973 1550 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
974 : return;
975 :
976 : /* Compare the two string lengths. */
977 94 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
978 :
979 : /* Output the runtime-check. */
980 94 : name = gfc_build_cstring_const (intr_name);
981 94 : name = gfc_build_addr_expr (pchar_type_node, name);
982 94 : 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
996 228 : gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
997 : {
998 228 : tree arg, type, res, tmp, frexp, cond, huge;
999 228 : int i;
1000 :
1001 456 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1002 228 : expr->value.function.actual->expr->ts.kind);
1003 :
1004 228 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1005 228 : arg = gfc_evaluate_now (arg, &se->pre);
1006 :
1007 228 : i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1008 228 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1009 228 : cond = build_call_expr_loc (input_location,
1010 : builtin_decl_explicit (BUILT_IN_ISFINITE),
1011 : 1, arg);
1012 :
1013 228 : res = gfc_create_var (integer_type_node, NULL);
1014 228 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1015 : gfc_build_addr_expr (NULL_TREE, res));
1016 228 : tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1017 : tmp, res);
1018 228 : se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1019 : cond, tmp, huge);
1020 :
1021 228 : type = gfc_typenode_for_spec (&expr->ts);
1022 228 : se->expr = fold_convert (type, se->expr);
1023 228 : }
1024 :
1025 :
1026 : static int caf_call_cnt = 0;
1027 :
1028 : static tree
1029 1434 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1030 : gfc_expr *hash)
1031 : {
1032 1434 : char *name;
1033 1434 : gfc_se argse;
1034 1434 : gfc_expr func_index;
1035 1434 : gfc_symtree *index_st;
1036 1434 : tree func_index_tree;
1037 1434 : stmtblock_t blk;
1038 :
1039 : /* Need to get namespace where static variables are possible. */
1040 1434 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1041 0 : ns = ns->parent;
1042 1434 : gcc_assert (ns);
1043 :
1044 1434 : name = xasprintf (pat, caf_call_cnt);
1045 1434 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1046 1434 : free (name);
1047 :
1048 1434 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1049 1434 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1050 1434 : index_st->n.sym->value
1051 1434 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1052 : &gfc_current_locus);
1053 1434 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1054 1434 : index_st->n.sym->ts.type = BT_INTEGER;
1055 1434 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1056 1434 : gfc_set_sym_referenced (index_st->n.sym);
1057 1434 : memset (&func_index, 0, sizeof (gfc_expr));
1058 1434 : gfc_clear_ts (&func_index.ts);
1059 1434 : func_index.expr_type = EXPR_VARIABLE;
1060 1434 : func_index.symtree = index_st;
1061 1434 : func_index.ts = index_st->n.sym->ts;
1062 1434 : gfc_commit_symbol (index_st->n.sym);
1063 :
1064 1434 : gfc_init_se (&argse, NULL);
1065 1434 : gfc_conv_expr (&argse, &func_index);
1066 1434 : gfc_add_block_to_block (block, &argse.pre);
1067 1434 : func_index_tree = argse.expr;
1068 :
1069 1434 : gfc_init_se (&argse, NULL);
1070 1434 : gfc_conv_expr (&argse, hash);
1071 :
1072 1434 : gfc_init_block (&blk);
1073 1434 : gfc_add_modify (&blk, func_index_tree,
1074 : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1075 : argse.expr));
1076 1434 : gfc_add_expr_to_block (
1077 : block,
1078 : build3 (COND_EXPR, void_type_node,
1079 : gfc_likely (build2 (EQ_EXPR, logical_type_node, func_index_tree,
1080 : build_int_cst (integer_type_node, -1)),
1081 : PRED_FIRST_MATCH),
1082 : gfc_finish_block (&blk), NULL_TREE));
1083 :
1084 1434 : return func_index_tree;
1085 : }
1086 :
1087 : static tree
1088 1434 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1089 : gfc_symbol *data_sym, tree *data_size)
1090 : {
1091 1434 : char *name;
1092 1434 : gfc_symtree *data_st;
1093 1434 : gfc_constructor *con;
1094 1434 : gfc_expr data, data_init;
1095 1434 : gfc_se argse;
1096 1434 : tree data_tree;
1097 :
1098 1434 : memset (&data, 0, sizeof (gfc_expr));
1099 1434 : gfc_clear_ts (&data.ts);
1100 1434 : data.expr_type = EXPR_VARIABLE;
1101 1434 : name = xasprintf (pat, caf_call_cnt);
1102 1434 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1103 1434 : free (name);
1104 1434 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1105 1434 : data_st->n.sym->ts = data_sym->ts;
1106 1434 : data.symtree = data_st;
1107 1434 : gfc_set_sym_referenced (data.symtree->n.sym);
1108 1434 : data.ts = data_st->n.sym->ts;
1109 1434 : gfc_commit_symbol (data_st->n.sym);
1110 :
1111 1434 : memset (&data_init, 0, sizeof (gfc_expr));
1112 1434 : gfc_clear_ts (&data_init.ts);
1113 1434 : data_init.expr_type = EXPR_STRUCTURE;
1114 1434 : data_init.ts = data.ts;
1115 1750 : for (gfc_component *comp = data.ts.u.derived->components; comp;
1116 316 : comp = comp->next)
1117 : {
1118 316 : con = gfc_constructor_get ();
1119 316 : con->expr = comp->initializer;
1120 316 : comp->initializer = NULL;
1121 316 : gfc_constructor_append (&data_init.value.constructor, con);
1122 : }
1123 :
1124 1434 : if (data.ts.u.derived->components)
1125 : {
1126 110 : gfc_init_se (&argse, NULL);
1127 110 : gfc_conv_expr (&argse, &data);
1128 110 : data_tree = argse.expr;
1129 110 : gfc_add_expr_to_block (blk,
1130 : gfc_trans_structure_assign (data_tree, &data_init,
1131 : true, true));
1132 110 : gfc_constructor_free (data_init.value.constructor);
1133 110 : *data_size = TREE_TYPE (data_tree)->type_common.size_unit;
1134 110 : data_tree = gfc_build_addr_expr (pvoid_type_node, data_tree);
1135 : }
1136 : else
1137 : {
1138 1324 : data_tree = build_zero_cst (pvoid_type_node);
1139 1324 : *data_size = build_zero_cst (size_type_node);
1140 : }
1141 :
1142 1434 : return data_tree;
1143 : }
1144 :
1145 : static tree
1146 251 : conv_shape_to_cst (gfc_expr *e)
1147 : {
1148 251 : tree tmp = NULL;
1149 690 : for (int d = 0; d < e->rank; ++d)
1150 : {
1151 439 : if (!tmp)
1152 251 : tmp = gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind);
1153 : else
1154 188 : tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp,
1155 : gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind));
1156 : }
1157 251 : return fold_convert (size_type_node, tmp);
1158 : }
1159 :
1160 : static void
1161 1267 : conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
1162 : tree *team_no)
1163 : {
1164 1267 : gfc_expr *stat_e, *team_e;
1165 :
1166 1267 : stat_e = gfc_find_stat_co (expr);
1167 1267 : if (stat_e)
1168 : {
1169 33 : gfc_se stat_se;
1170 33 : gfc_init_se (&stat_se, NULL);
1171 33 : gfc_conv_expr_reference (&stat_se, stat_e);
1172 33 : *stat = stat_se.expr;
1173 33 : gfc_add_block_to_block (block, &stat_se.pre);
1174 33 : gfc_add_block_to_block (block, &stat_se.post);
1175 : }
1176 : else
1177 1234 : *stat = null_pointer_node;
1178 :
1179 1267 : team_e = gfc_find_team_co (expr, TEAM_TEAM);
1180 1267 : if (team_e)
1181 : {
1182 18 : gfc_se team_se;
1183 18 : gfc_init_se (&team_se, NULL);
1184 18 : gfc_conv_expr (&team_se, team_e);
1185 18 : *team
1186 18 : = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
1187 : team_se.expr));
1188 18 : gfc_add_block_to_block (block, &team_se.pre);
1189 18 : gfc_add_block_to_block (block, &team_se.post);
1190 : }
1191 : else
1192 1249 : *team = null_pointer_node;
1193 :
1194 1267 : team_e = gfc_find_team_co (expr, TEAM_NUMBER);
1195 1267 : if (team_e)
1196 : {
1197 30 : gfc_se team_se;
1198 30 : gfc_init_se (&team_se, NULL);
1199 30 : gfc_conv_expr (&team_se, team_e);
1200 30 : *team_no = gfc_build_addr_expr (
1201 : NULL_TREE,
1202 : gfc_trans_force_lval (&team_se.pre,
1203 : fold_convert (integer_type_node, team_se.expr)));
1204 30 : gfc_add_block_to_block (block, &team_se.pre);
1205 30 : gfc_add_block_to_block (block, &team_se.post);
1206 : }
1207 : else
1208 1237 : *team_no = null_pointer_node;
1209 1267 : }
1210 :
1211 : /* Get data from a remote coarray. */
1212 :
1213 : static void
1214 1006 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
1215 : bool may_realloc, symbol_attribute *caf_attr)
1216 : {
1217 1006 : gfc_expr *array_expr;
1218 1006 : tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size,
1219 : dest_data, opt_dest_desc, get_fn_index_tree, add_data_tree, add_data_size,
1220 : opt_src_desc, opt_src_charlen, opt_dest_charlen, team, team_no;
1221 1006 : symbol_attribute caf_attr_store;
1222 1006 : gfc_namespace *ns;
1223 1006 : gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
1224 1006 : *get_fn_expr = expr->value.function.actual->next->next->expr;
1225 1006 : gfc_symbol *add_data_sym = get_fn_expr->symtree->n.sym->formal->sym;
1226 :
1227 1006 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1228 :
1229 1006 : if (se->ss && se->ss->info->useflags)
1230 : {
1231 : /* Access the previously obtained result. */
1232 379 : gfc_conv_tmp_array_ref (se);
1233 379 : return;
1234 : }
1235 :
1236 627 : array_expr = expr->value.function.actual->expr;
1237 627 : ns = array_expr->expr_type == EXPR_VARIABLE
1238 627 : && !array_expr->symtree->n.sym->attr.associate_var
1239 571 : && !array_expr->symtree->n.sym->module
1240 627 : ? array_expr->symtree->n.sym->ns
1241 : : gfc_current_ns;
1242 627 : type = gfc_typenode_for_spec (&array_expr->ts);
1243 :
1244 627 : if (caf_attr == NULL)
1245 : {
1246 627 : caf_attr_store = gfc_caf_attr (array_expr);
1247 627 : caf_attr = &caf_attr_store;
1248 : }
1249 :
1250 627 : res_var = lhs;
1251 :
1252 627 : conv_stat_and_team (&se->pre, expr, &stat, &team, &team_no);
1253 :
1254 627 : get_fn_index_tree
1255 627 : = conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
1256 : get_fn_hash);
1257 627 : add_data_tree
1258 627 : = conv_caf_add_call_data (&se->pre, ns, "__caf_get_from_remote_add_data_%d",
1259 : add_data_sym, &add_data_size);
1260 627 : ++caf_call_cnt;
1261 :
1262 627 : if (array_expr->rank == 0)
1263 : {
1264 246 : res_var = gfc_create_var (type, "caf_res");
1265 246 : if (array_expr->ts.type == BT_CHARACTER)
1266 : {
1267 33 : gfc_conv_string_length (array_expr->ts.u.cl, array_expr, &se->pre);
1268 33 : se->string_length = array_expr->ts.u.cl->backend_decl;
1269 33 : opt_src_charlen = gfc_build_addr_expr (
1270 : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1271 33 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1272 : }
1273 : else
1274 : {
1275 213 : dest_size = res_var->typed.type->type_common.size_unit;
1276 213 : opt_src_charlen
1277 213 : = build_zero_cst (build_pointer_type (size_type_node));
1278 : }
1279 246 : dest_data
1280 246 : = gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre);
1281 246 : res_var = build_fold_indirect_ref (dest_data);
1282 246 : dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data);
1283 246 : opt_dest_desc = build_zero_cst (pvoid_type_node);
1284 : }
1285 : else
1286 : {
1287 : /* Create temporary. */
1288 381 : may_realloc = gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
1289 : type, NULL_TREE, false, false,
1290 : false, &array_expr->where)
1291 : == NULL_TREE;
1292 381 : res_var = se->ss->info->data.array.descriptor;
1293 381 : if (array_expr->ts.type == BT_CHARACTER)
1294 : {
1295 16 : se->string_length = array_expr->ts.u.cl->backend_decl;
1296 16 : opt_src_charlen = gfc_build_addr_expr (
1297 : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1298 16 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1299 : }
1300 : else
1301 : {
1302 365 : opt_src_charlen
1303 365 : = build_zero_cst (build_pointer_type (size_type_node));
1304 365 : dest_size = fold_build2 (
1305 : MULT_EXPR, size_type_node,
1306 : fold_convert (size_type_node,
1307 : array_expr->shape
1308 : ? conv_shape_to_cst (array_expr)
1309 : : gfc_conv_descriptor_size (res_var,
1310 : array_expr->rank)),
1311 : fold_convert (size_type_node,
1312 : gfc_conv_descriptor_span_get (res_var)));
1313 : }
1314 381 : opt_dest_desc = res_var;
1315 381 : dest_data = gfc_conv_descriptor_data_get (res_var);
1316 381 : opt_dest_desc = gfc_build_addr_expr (NULL_TREE, opt_dest_desc);
1317 381 : if (may_realloc)
1318 : {
1319 62 : tmp = gfc_conv_descriptor_data_get (res_var);
1320 62 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1321 : NULL_TREE, NULL_TREE, true, NULL,
1322 : GFC_CAF_COARRAY_NOCOARRAY);
1323 62 : gfc_add_expr_to_block (&se->post, tmp);
1324 : }
1325 381 : dest_data
1326 381 : = gfc_build_addr_expr (NULL_TREE,
1327 : gfc_trans_force_lval (&se->pre, dest_data));
1328 : }
1329 :
1330 627 : opt_dest_charlen = opt_src_charlen;
1331 627 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1332 627 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1333 2 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1334 :
1335 627 : if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
1336 627 : || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
1337 546 : opt_src_desc = build_zero_cst (pvoid_type_node);
1338 : else
1339 81 : opt_src_desc = gfc_build_addr_expr (pvoid_type_node, caf_decl);
1340 :
1341 627 : image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1342 627 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr);
1343 :
1344 : /* It guarantees memory consistency within the same segment. */
1345 627 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1346 627 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1347 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1348 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1349 627 : ASM_VOLATILE_P (tmp) = 1;
1350 627 : gfc_add_expr_to_block (&se->pre, tmp);
1351 :
1352 627 : tmp = build_call_expr_loc (
1353 : input_location, gfor_fndecl_caf_get_from_remote, 15, token, opt_src_desc,
1354 : opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen,
1355 : opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node),
1356 : get_fn_index_tree, add_data_tree, add_data_size, stat, team, team_no);
1357 :
1358 627 : gfc_add_expr_to_block (&se->pre, tmp);
1359 :
1360 627 : if (se->ss)
1361 381 : gfc_advance_se_ss_chain (se);
1362 :
1363 627 : se->expr = res_var;
1364 :
1365 627 : return;
1366 : }
1367 :
1368 : /* Generate call to caf_is_present_on_remote for allocated (coarrary[...])
1369 : calls. */
1370 :
1371 : static void
1372 167 : gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1373 : {
1374 167 : gfc_expr *caf_expr, *hash, *present_fn;
1375 167 : gfc_symbol *add_data_sym;
1376 167 : tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1377 :
1378 167 : gcc_assert (e->expr_type == EXPR_FUNCTION
1379 : && e->value.function.isym->id
1380 : == GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1381 167 : caf_expr = e->value.function.actual->expr;
1382 167 : hash = e->value.function.actual->next->expr;
1383 167 : present_fn = e->value.function.actual->next->next->expr;
1384 167 : add_data_sym = present_fn->symtree->n.sym->formal->sym;
1385 :
1386 167 : fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
1387 : "__caf_present_on_remote_fn_index_%d", hash);
1388 167 : add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns,
1389 : "__caf_present_on_remote_add_data_%d",
1390 : add_data_sym, &add_data_size);
1391 167 : ++caf_call_cnt;
1392 :
1393 167 : caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1394 167 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1395 4 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1396 :
1397 167 : image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1398 167 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1399 :
1400 167 : se->expr
1401 167 : = fold_convert (logical_type_node,
1402 : build_call_expr_loc (input_location,
1403 : gfor_fndecl_caf_is_present_on_remote,
1404 : 5, token, image_index, fn_index,
1405 : add_data_tree, add_data_size));
1406 167 : }
1407 :
1408 : static tree
1409 360 : conv_caf_send_to_remote (gfc_code *code)
1410 : {
1411 360 : gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr;
1412 360 : gfc_symbol *add_data_sym;
1413 360 : gfc_se lhs_se, rhs_se;
1414 360 : stmtblock_t block;
1415 360 : gfc_namespace *ns;
1416 360 : tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
1417 360 : tree lhs_stat, lhs_team, lhs_team_no, opt_lhs_charlen, opt_rhs_charlen;
1418 360 : tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
1419 360 : tree receiver_fn_index_tree, add_data_tree, add_data_size;
1420 :
1421 360 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1422 360 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SEND);
1423 :
1424 360 : lhs_expr = code->ext.actual->expr;
1425 360 : rhs_expr = code->ext.actual->next->expr;
1426 360 : lhs_hash = code->ext.actual->next->next->expr;
1427 360 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1428 360 : add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1429 :
1430 360 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1431 360 : && !lhs_expr->symtree->n.sym->attr.associate_var
1432 360 : ? lhs_expr->symtree->n.sym->ns
1433 : : gfc_current_ns;
1434 :
1435 360 : gfc_init_block (&block);
1436 :
1437 : /* LHS. */
1438 360 : gfc_init_se (&lhs_se, NULL);
1439 360 : caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1440 360 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1441 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1442 360 : if (lhs_expr->rank == 0)
1443 : {
1444 266 : if (lhs_expr->ts.type == BT_CHARACTER)
1445 : {
1446 24 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1447 24 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1448 24 : opt_lhs_charlen = gfc_build_addr_expr (
1449 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1450 : }
1451 : else
1452 242 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1453 266 : opt_lhs_desc = null_pointer_node;
1454 : }
1455 : else
1456 : {
1457 94 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1458 94 : gfc_add_block_to_block (&block, &lhs_se.pre);
1459 94 : opt_lhs_desc = lhs_se.expr;
1460 94 : if (lhs_expr->ts.type == BT_CHARACTER)
1461 44 : opt_lhs_charlen = gfc_build_addr_expr (
1462 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1463 : else
1464 50 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1465 : /* Get the third formal argument of the receiver function. (This is the
1466 : location where to put the data on the remote image.) Need to look at
1467 : the argument in the function decl, because in the gfc_symbol's formal
1468 : argument an array may have no descriptor while in the generated
1469 : function decl it has. */
1470 94 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1471 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1472 94 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1473 56 : opt_lhs_desc = null_pointer_node;
1474 : else
1475 38 : opt_lhs_desc
1476 38 : = gfc_build_addr_expr (NULL_TREE,
1477 : gfc_trans_force_lval (&block, opt_lhs_desc));
1478 : }
1479 :
1480 : /* Obtain token, offset and image index for the LHS. */
1481 360 : image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1482 360 : gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL, lhs_expr);
1483 :
1484 : /* RHS. */
1485 360 : gfc_init_se (&rhs_se, NULL);
1486 360 : if (rhs_expr->rank == 0)
1487 : {
1488 436 : rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER
1489 218 : && rhs_expr->expr_type != EXPR_CONSTANT;
1490 218 : gfc_conv_expr (&rhs_se, rhs_expr);
1491 218 : gfc_add_block_to_block (&block, &rhs_se.pre);
1492 218 : opt_rhs_desc = null_pointer_node;
1493 218 : if (rhs_expr->ts.type == BT_CHARACTER)
1494 : {
1495 40 : rhs_data
1496 40 : = rhs_expr->expr_type == EXPR_CONSTANT
1497 40 : ? gfc_build_addr_expr (NULL_TREE,
1498 : gfc_trans_force_lval (&block,
1499 : rhs_se.expr))
1500 : : rhs_se.expr;
1501 40 : opt_rhs_charlen = gfc_build_addr_expr (
1502 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1503 40 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1504 : }
1505 : else
1506 : {
1507 178 : rhs_data
1508 178 : = gfc_build_addr_expr (NULL_TREE,
1509 : gfc_trans_force_lval (&block, rhs_se.expr));
1510 178 : opt_rhs_charlen
1511 178 : = build_zero_cst (build_pointer_type (size_type_node));
1512 178 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1513 : }
1514 : }
1515 : else
1516 : {
1517 284 : rhs_se.force_tmp = rhs_expr->shape == NULL
1518 142 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1519 142 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1520 142 : gfc_add_block_to_block (&block, &rhs_se.pre);
1521 142 : opt_rhs_desc = rhs_se.expr;
1522 142 : if (rhs_expr->ts.type == BT_CHARACTER)
1523 : {
1524 28 : opt_rhs_charlen = gfc_build_addr_expr (
1525 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1526 28 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1527 : }
1528 : else
1529 : {
1530 114 : opt_rhs_charlen
1531 114 : = build_zero_cst (build_pointer_type (size_type_node));
1532 114 : rhs_size = fold_build2 (
1533 : MULT_EXPR, size_type_node,
1534 : fold_convert (size_type_node,
1535 : rhs_expr->shape
1536 : ? conv_shape_to_cst (rhs_expr)
1537 : : gfc_conv_descriptor_size (rhs_se.expr,
1538 : rhs_expr->rank)),
1539 : fold_convert (size_type_node,
1540 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1541 : }
1542 :
1543 142 : rhs_data = gfc_build_addr_expr (
1544 : NULL_TREE, gfc_trans_force_lval (&block, gfc_conv_descriptor_data_get (
1545 : opt_rhs_desc)));
1546 142 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1547 : }
1548 360 : gfc_add_block_to_block (&block, &rhs_se.pre);
1549 :
1550 360 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1551 :
1552 360 : receiver_fn_index_tree
1553 360 : = conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
1554 : lhs_hash);
1555 360 : add_data_tree
1556 360 : = conv_caf_add_call_data (&block, ns, "__caf_send_to_remote_add_data_%d",
1557 : add_data_sym, &add_data_size);
1558 360 : ++caf_call_cnt;
1559 :
1560 360 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
1561 : token, opt_lhs_desc, opt_lhs_charlen, image_index,
1562 : rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
1563 : receiver_fn_index_tree, add_data_tree,
1564 : add_data_size, lhs_stat, lhs_team, lhs_team_no);
1565 :
1566 360 : gfc_add_expr_to_block (&block, tmp);
1567 360 : gfc_add_block_to_block (&block, &lhs_se.post);
1568 360 : gfc_add_block_to_block (&block, &rhs_se.post);
1569 :
1570 : /* It guarantees memory consistency within the same segment. */
1571 360 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1572 360 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1573 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1574 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1575 360 : ASM_VOLATILE_P (tmp) = 1;
1576 360 : gfc_add_expr_to_block (&block, tmp);
1577 :
1578 360 : return gfc_finish_block (&block);
1579 : }
1580 :
1581 : /* Send-get data to a remote coarray. */
1582 :
1583 : static tree
1584 140 : conv_caf_sendget (gfc_code *code)
1585 : {
1586 : /* lhs stuff */
1587 140 : gfc_expr *lhs_expr, *lhs_hash, *receiver_fn_expr;
1588 140 : gfc_symbol *lhs_add_data_sym;
1589 140 : gfc_se lhs_se;
1590 140 : tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
1591 140 : opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
1592 : lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team, lhs_team_no;
1593 140 : int transfer_rank;
1594 :
1595 : /* rhs stuff */
1596 140 : gfc_expr *rhs_expr, *rhs_hash, *sender_fn_expr;
1597 140 : gfc_symbol *rhs_add_data_sym;
1598 140 : gfc_se rhs_se;
1599 140 : tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
1600 140 : opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
1601 : rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team, rhs_team_no;
1602 :
1603 : /* shared */
1604 140 : stmtblock_t block;
1605 140 : gfc_namespace *ns;
1606 140 : tree tmp, rhs_size;
1607 :
1608 140 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1609 140 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SENDGET);
1610 :
1611 140 : lhs_expr = code->ext.actual->expr;
1612 140 : rhs_expr = code->ext.actual->next->expr;
1613 140 : lhs_hash = code->ext.actual->next->next->expr;
1614 140 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1615 140 : rhs_hash = code->ext.actual->next->next->next->next->expr;
1616 140 : sender_fn_expr = code->ext.actual->next->next->next->next->next->expr;
1617 :
1618 140 : lhs_add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1619 140 : rhs_add_data_sym = sender_fn_expr->symtree->n.sym->formal->sym;
1620 :
1621 140 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1622 140 : && !lhs_expr->symtree->n.sym->attr.associate_var
1623 140 : ? lhs_expr->symtree->n.sym->ns
1624 : : gfc_current_ns;
1625 :
1626 140 : gfc_init_block (&block);
1627 :
1628 140 : lhs_stat = null_pointer_node;
1629 140 : lhs_team = null_pointer_node;
1630 140 : rhs_stat = null_pointer_node;
1631 140 : rhs_team = null_pointer_node;
1632 :
1633 : /* LHS. */
1634 140 : gfc_init_se (&lhs_se, NULL);
1635 140 : lhs_caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1636 140 : if (TREE_CODE (TREE_TYPE (lhs_caf_decl)) == REFERENCE_TYPE)
1637 0 : lhs_caf_decl = build_fold_indirect_ref_loc (input_location, lhs_caf_decl);
1638 140 : if (lhs_expr->rank == 0)
1639 : {
1640 78 : if (lhs_expr->ts.type == BT_CHARACTER)
1641 : {
1642 16 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1643 16 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1644 16 : opt_lhs_charlen = gfc_build_addr_expr (
1645 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1646 : }
1647 : else
1648 62 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1649 78 : opt_lhs_desc = null_pointer_node;
1650 : }
1651 : else
1652 : {
1653 62 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1654 62 : gfc_add_block_to_block (&block, &lhs_se.pre);
1655 62 : opt_lhs_desc = lhs_se.expr;
1656 62 : if (lhs_expr->ts.type == BT_CHARACTER)
1657 32 : opt_lhs_charlen = gfc_build_addr_expr (
1658 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1659 : else
1660 30 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1661 : /* Get the third formal argument of the receiver function. (This is the
1662 : location where to put the data on the remote image.) Need to look at
1663 : the argument in the function decl, because in the gfc_symbol's formal
1664 : argument an array may have no descriptor while in the generated
1665 : function decl it has. */
1666 62 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1667 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1668 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1669 54 : opt_lhs_desc = null_pointer_node;
1670 : else
1671 8 : opt_lhs_desc
1672 8 : = gfc_build_addr_expr (NULL_TREE,
1673 : gfc_trans_force_lval (&block, opt_lhs_desc));
1674 : }
1675 :
1676 : /* Obtain token, offset and image index for the LHS. */
1677 140 : lhs_image_index = gfc_caf_get_image_index (&block, lhs_expr, lhs_caf_decl);
1678 140 : gfc_get_caf_token_offset (&lhs_se, &lhs_token, NULL, lhs_caf_decl, NULL,
1679 : lhs_expr);
1680 :
1681 : /* RHS. */
1682 140 : rhs_caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
1683 140 : if (TREE_CODE (TREE_TYPE (rhs_caf_decl)) == REFERENCE_TYPE)
1684 0 : rhs_caf_decl = build_fold_indirect_ref_loc (input_location, rhs_caf_decl);
1685 140 : transfer_rank = rhs_expr->rank;
1686 140 : gfc_expression_rank (rhs_expr);
1687 140 : gfc_init_se (&rhs_se, NULL);
1688 140 : if (rhs_expr->rank == 0)
1689 : {
1690 80 : opt_rhs_desc = null_pointer_node;
1691 80 : if (rhs_expr->ts.type == BT_CHARACTER)
1692 : {
1693 32 : gfc_conv_expr (&rhs_se, rhs_expr);
1694 32 : gfc_add_block_to_block (&block, &rhs_se.pre);
1695 32 : opt_rhs_charlen = gfc_build_addr_expr (
1696 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1697 32 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1698 : }
1699 : else
1700 : {
1701 48 : gfc_typespec *ts
1702 48 : = &sender_fn_expr->symtree->n.sym->formal->next->next->sym->ts;
1703 :
1704 48 : opt_rhs_charlen
1705 48 : = build_zero_cst (build_pointer_type (size_type_node));
1706 48 : rhs_size = gfc_typenode_for_spec (ts)->type_common.size_unit;
1707 : }
1708 : }
1709 : /* Get the fifth formal argument of the getter function. This is the argument
1710 : pointing to the data to get on the remote image. Need to look at the
1711 : argument in the function decl, because in the gfc_symbol's formal argument
1712 : an array may have no descriptor while in the generated function decl it
1713 : has. */
1714 60 : else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_VALUE (
1715 : TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1716 : TREE_TYPE (sender_fn_expr->symtree->n.sym->backend_decl))))))))))
1717 : {
1718 52 : rhs_se.data_not_needed = 1;
1719 52 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1720 52 : gfc_add_block_to_block (&block, &rhs_se.pre);
1721 52 : if (rhs_expr->ts.type == BT_CHARACTER)
1722 : {
1723 16 : opt_rhs_charlen = gfc_build_addr_expr (
1724 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1725 16 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1726 : }
1727 : else
1728 : {
1729 36 : opt_rhs_charlen
1730 36 : = build_zero_cst (build_pointer_type (size_type_node));
1731 36 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1732 : }
1733 52 : opt_rhs_desc = null_pointer_node;
1734 : }
1735 : else
1736 : {
1737 8 : gfc_ref *arr_ref = rhs_expr->ref;
1738 8 : while (arr_ref && arr_ref->type != REF_ARRAY)
1739 0 : arr_ref = arr_ref->next;
1740 8 : rhs_se.force_tmp
1741 16 : = (rhs_expr->shape == NULL
1742 8 : && (!arr_ref || !gfc_full_array_ref_p (arr_ref, nullptr)))
1743 16 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1744 8 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1745 8 : gfc_add_block_to_block (&block, &rhs_se.pre);
1746 8 : opt_rhs_desc = rhs_se.expr;
1747 8 : if (rhs_expr->ts.type == BT_CHARACTER)
1748 : {
1749 0 : opt_rhs_charlen = gfc_build_addr_expr (
1750 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1751 0 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1752 : }
1753 : else
1754 : {
1755 8 : opt_rhs_charlen
1756 8 : = build_zero_cst (build_pointer_type (size_type_node));
1757 8 : rhs_size = fold_build2 (
1758 : MULT_EXPR, size_type_node,
1759 : fold_convert (size_type_node,
1760 : rhs_expr->shape
1761 : ? conv_shape_to_cst (rhs_expr)
1762 : : gfc_conv_descriptor_size (rhs_se.expr,
1763 : rhs_expr->rank)),
1764 : fold_convert (size_type_node,
1765 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1766 : }
1767 :
1768 8 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1769 : }
1770 140 : gfc_add_block_to_block (&block, &rhs_se.pre);
1771 :
1772 : /* Obtain token, offset and image index for the RHS. */
1773 140 : rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, rhs_caf_decl);
1774 140 : gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, rhs_caf_decl, NULL,
1775 : rhs_expr);
1776 :
1777 : /* stat and team. */
1778 140 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1779 140 : conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team, &rhs_team_no);
1780 :
1781 140 : sender_fn_index_tree
1782 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_from_fn_index_%d",
1783 : rhs_hash);
1784 140 : rhs_add_data_tree
1785 140 : = conv_caf_add_call_data (&block, ns,
1786 : "__caf_transfer_from_remote_add_data_%d",
1787 : rhs_add_data_sym, &rhs_add_data_size);
1788 140 : receiver_fn_index_tree
1789 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_to_remote_fn_index_%d",
1790 : lhs_hash);
1791 140 : lhs_add_data_tree
1792 140 : = conv_caf_add_call_data (&block, ns,
1793 : "__caf_transfer_to_remote_add_data_%d",
1794 : lhs_add_data_sym, &lhs_add_data_size);
1795 140 : ++caf_call_cnt;
1796 :
1797 140 : tmp = build_call_expr_loc (
1798 : input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
1799 : opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
1800 : lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
1801 : opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
1802 : rhs_add_data_size, rhs_size,
1803 : transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
1804 : rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
1805 :
1806 140 : gfc_add_expr_to_block (&block, tmp);
1807 140 : gfc_add_block_to_block (&block, &lhs_se.post);
1808 140 : gfc_add_block_to_block (&block, &rhs_se.post);
1809 :
1810 : /* It guarantees memory consistency within the same segment. */
1811 140 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1812 140 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1813 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1814 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1815 140 : ASM_VOLATILE_P (tmp) = 1;
1816 140 : gfc_add_expr_to_block (&block, tmp);
1817 :
1818 140 : return gfc_finish_block (&block);
1819 : }
1820 :
1821 :
1822 : static void
1823 1298 : trans_this_image (gfc_se * se, gfc_expr *expr)
1824 : {
1825 1298 : stmtblock_t loop;
1826 1298 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1827 : ubound, extent, ml, team;
1828 1298 : gfc_se argse;
1829 1298 : int rank, corank;
1830 :
1831 : /* The case -fcoarray=single is handled elsewhere. */
1832 1298 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1833 :
1834 : /* Translate team, if present. */
1835 1298 : if (expr->value.function.actual->next->next->expr)
1836 : {
1837 18 : gfc_init_se (&argse, NULL);
1838 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr);
1839 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
1840 18 : gfc_add_block_to_block (&se->post, &argse.post);
1841 18 : team = fold_convert (pvoid_type_node, argse.expr);
1842 : }
1843 : else
1844 1280 : team = null_pointer_node;
1845 :
1846 : /* Argument-free version: THIS_IMAGE(). */
1847 1298 : if (expr->value.function.actual->expr == NULL)
1848 : {
1849 980 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1850 : team);
1851 980 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1852 : tmp);
1853 988 : return;
1854 : }
1855 :
1856 : /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1857 :
1858 318 : type = gfc_get_int_type (gfc_default_integer_kind);
1859 318 : corank = expr->value.function.actual->expr->corank;
1860 318 : rank = expr->value.function.actual->expr->rank;
1861 :
1862 : /* Obtain the descriptor of the COARRAY. */
1863 318 : gfc_init_se (&argse, NULL);
1864 318 : argse.want_coarray = 1;
1865 318 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1866 318 : gfc_add_block_to_block (&se->pre, &argse.pre);
1867 318 : gfc_add_block_to_block (&se->post, &argse.post);
1868 318 : desc = argse.expr;
1869 :
1870 318 : if (se->ss)
1871 : {
1872 : /* Create an implicit second parameter from the loop variable. */
1873 70 : gcc_assert (!expr->value.function.actual->next->expr);
1874 70 : gcc_assert (corank > 0);
1875 70 : gcc_assert (se->loop->dimen == 1);
1876 70 : gcc_assert (se->ss->info->expr == expr);
1877 :
1878 70 : dim_arg = se->loop->loopvar[0];
1879 70 : dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1880 : gfc_array_index_type, dim_arg,
1881 70 : build_int_cst (TREE_TYPE (dim_arg), 1));
1882 70 : gfc_advance_se_ss_chain (se);
1883 : }
1884 : else
1885 : {
1886 : /* Use the passed DIM= argument. */
1887 248 : gcc_assert (expr->value.function.actual->next->expr);
1888 248 : gfc_init_se (&argse, NULL);
1889 248 : gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1890 : gfc_array_index_type);
1891 248 : gfc_add_block_to_block (&se->pre, &argse.pre);
1892 248 : dim_arg = argse.expr;
1893 :
1894 248 : if (INTEGER_CST_P (dim_arg))
1895 : {
1896 132 : if (wi::ltu_p (wi::to_wide (dim_arg), 1)
1897 264 : || wi::gtu_p (wi::to_wide (dim_arg),
1898 132 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1899 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1900 0 : "dimension index", expr->value.function.isym->name,
1901 : &expr->where);
1902 : }
1903 116 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1904 : {
1905 0 : dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1906 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1907 : dim_arg,
1908 0 : build_int_cst (TREE_TYPE (dim_arg), 1));
1909 0 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1910 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1911 : dim_arg, tmp);
1912 0 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1913 : logical_type_node, cond, tmp);
1914 0 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1915 : gfc_msg_fault);
1916 : }
1917 : }
1918 :
1919 : /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1920 : one always has a dim_arg argument.
1921 :
1922 : m = this_image() - 1
1923 : if (corank == 1)
1924 : {
1925 : sub(1) = m + lcobound(corank)
1926 : return;
1927 : }
1928 : i = rank
1929 : min_var = min (rank + corank - 2, rank + dim_arg - 1)
1930 : for (;;)
1931 : {
1932 : extent = gfc_extent(i)
1933 : ml = m
1934 : m = m/extent
1935 : if (i >= min_var)
1936 : goto exit_label
1937 : i++
1938 : }
1939 : exit_label:
1940 : sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1941 : : m + lcobound(corank)
1942 : */
1943 :
1944 : /* this_image () - 1. */
1945 318 : tmp
1946 318 : = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team);
1947 318 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
1948 : fold_convert (type, tmp), build_int_cst (type, 1));
1949 318 : if (corank == 1)
1950 : {
1951 : /* sub(1) = m + lcobound(corank). */
1952 8 : lbound = gfc_conv_descriptor_lbound_get (desc,
1953 8 : build_int_cst (TREE_TYPE (gfc_array_index_type),
1954 8 : corank+rank-1));
1955 8 : lbound = fold_convert (type, lbound);
1956 8 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1957 :
1958 8 : se->expr = tmp;
1959 8 : return;
1960 : }
1961 :
1962 310 : m = gfc_create_var (type, NULL);
1963 310 : ml = gfc_create_var (type, NULL);
1964 310 : loop_var = gfc_create_var (integer_type_node, NULL);
1965 310 : min_var = gfc_create_var (integer_type_node, NULL);
1966 :
1967 : /* m = this_image () - 1. */
1968 310 : gfc_add_modify (&se->pre, m, tmp);
1969 :
1970 : /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1971 310 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1972 : fold_convert (integer_type_node, dim_arg),
1973 310 : build_int_cst (integer_type_node, rank - 1));
1974 310 : tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1975 310 : build_int_cst (integer_type_node, rank + corank - 2),
1976 : tmp);
1977 310 : gfc_add_modify (&se->pre, min_var, tmp);
1978 :
1979 : /* i = rank. */
1980 310 : tmp = build_int_cst (integer_type_node, rank);
1981 310 : gfc_add_modify (&se->pre, loop_var, tmp);
1982 :
1983 310 : exit_label = gfc_build_label_decl (NULL_TREE);
1984 310 : TREE_USED (exit_label) = 1;
1985 :
1986 : /* Loop body. */
1987 310 : gfc_init_block (&loop);
1988 :
1989 : /* ml = m. */
1990 310 : gfc_add_modify (&loop, ml, m);
1991 :
1992 : /* extent = ... */
1993 310 : lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1994 310 : ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1995 310 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1996 310 : extent = fold_convert (type, extent);
1997 :
1998 : /* m = m/extent. */
1999 310 : gfc_add_modify (&loop, m,
2000 : fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2001 : m, extent));
2002 :
2003 : /* Exit condition: if (i >= min_var) goto exit_label. */
2004 310 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2005 : min_var);
2006 310 : tmp = build1_v (GOTO_EXPR, exit_label);
2007 310 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2008 : build_empty_stmt (input_location));
2009 310 : gfc_add_expr_to_block (&loop, tmp);
2010 :
2011 : /* Increment loop variable: i++. */
2012 310 : gfc_add_modify (&loop, loop_var,
2013 : fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2014 : loop_var,
2015 : integer_one_node));
2016 :
2017 : /* Making the loop... actually loop! */
2018 310 : tmp = gfc_finish_block (&loop);
2019 310 : tmp = build1_v (LOOP_EXPR, tmp);
2020 310 : gfc_add_expr_to_block (&se->pre, tmp);
2021 :
2022 : /* The exit label. */
2023 310 : tmp = build1_v (LABEL_EXPR, exit_label);
2024 310 : gfc_add_expr_to_block (&se->pre, tmp);
2025 :
2026 : /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2027 : : m + lcobound(corank) */
2028 :
2029 310 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2030 310 : build_int_cst (TREE_TYPE (dim_arg), corank));
2031 :
2032 310 : lbound = gfc_conv_descriptor_lbound_get (desc,
2033 : fold_build2_loc (input_location, PLUS_EXPR,
2034 : gfc_array_index_type, dim_arg,
2035 310 : build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2036 310 : lbound = fold_convert (type, lbound);
2037 :
2038 310 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2039 : fold_build2_loc (input_location, MULT_EXPR, type,
2040 : m, extent));
2041 310 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2042 :
2043 310 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2044 : fold_build2_loc (input_location, PLUS_EXPR, type,
2045 : m, lbound));
2046 : }
2047 :
2048 :
2049 : /* Convert a call to image_status. */
2050 :
2051 : static void
2052 25 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2053 : {
2054 25 : unsigned int num_args;
2055 25 : tree *args, tmp;
2056 :
2057 25 : num_args = gfc_intrinsic_argument_list_length (expr);
2058 25 : args = XALLOCAVEC (tree, num_args);
2059 25 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2060 : /* In args[0] the number of the image the status is desired for has to be
2061 : given. */
2062 :
2063 25 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2064 : {
2065 0 : tree arg;
2066 0 : arg = gfc_evaluate_now (args[0], &se->pre);
2067 0 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2068 : fold_convert (integer_type_node, arg),
2069 : integer_one_node);
2070 0 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2071 : tmp, integer_zero_node,
2072 : build_int_cst (integer_type_node,
2073 : GFC_STAT_STOPPED_IMAGE));
2074 : }
2075 25 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2076 : /* The team is optional and therefore needs to be a pointer to the opaque
2077 : pointer. */
2078 29 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2079 : args[0],
2080 : num_args < 2
2081 : ? null_pointer_node
2082 4 : : gfc_build_addr_expr (NULL_TREE, args[1]));
2083 : else
2084 0 : gcc_unreachable ();
2085 :
2086 25 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2087 25 : }
2088 :
2089 : static void
2090 21 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2091 : {
2092 21 : unsigned int num_args;
2093 :
2094 21 : tree *args, tmp;
2095 :
2096 21 : num_args = gfc_intrinsic_argument_list_length (expr);
2097 21 : args = XALLOCAVEC (tree, num_args);
2098 21 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2099 :
2100 21 : if (flag_coarray ==
2101 18 : GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2102 0 : tmp = gfc_evaluate_now (args[0], &se->pre);
2103 21 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2104 : {
2105 : // the value -1 represents that no team has been created yet
2106 18 : tmp = build_int_cst (integer_type_node, -1);
2107 : }
2108 3 : else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2109 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2110 : args[0]);
2111 3 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2112 3 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2113 : null_pointer_node);
2114 : else
2115 0 : gcc_unreachable ();
2116 :
2117 21 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2118 21 : }
2119 :
2120 :
2121 : static void
2122 193 : trans_image_index (gfc_se * se, gfc_expr *expr)
2123 : {
2124 193 : tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
2125 193 : invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
2126 193 : gfc_se argse, subse;
2127 193 : int rank, corank, codim;
2128 :
2129 193 : type = gfc_get_int_type (gfc_default_integer_kind);
2130 193 : corank = expr->value.function.actual->expr->corank;
2131 193 : rank = expr->value.function.actual->expr->rank;
2132 :
2133 : /* Obtain the descriptor of the COARRAY. */
2134 193 : gfc_init_se (&argse, NULL);
2135 193 : argse.want_coarray = 1;
2136 193 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2137 193 : gfc_add_block_to_block (&se->pre, &argse.pre);
2138 193 : gfc_add_block_to_block (&se->post, &argse.post);
2139 193 : desc = argse.expr;
2140 :
2141 : /* Obtain a handle to the SUB argument. */
2142 193 : gfc_init_se (&subse, NULL);
2143 193 : gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2144 193 : gfc_add_block_to_block (&se->pre, &subse.pre);
2145 193 : gfc_add_block_to_block (&se->post, &subse.post);
2146 193 : subdesc = build_fold_indirect_ref_loc (input_location,
2147 : gfc_conv_descriptor_data_get (subse.expr));
2148 :
2149 193 : if (expr->value.function.actual->next->next->expr)
2150 : {
2151 0 : gfc_init_se (&argse, NULL);
2152 0 : gfc_conv_expr_descriptor (&argse,
2153 0 : expr->value.function.actual->next->next->expr);
2154 0 : if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED)
2155 0 : team = argse.expr;
2156 : else
2157 0 : team_number = gfc_build_addr_expr (
2158 : NULL_TREE,
2159 : gfc_trans_force_lval (&argse.pre,
2160 : fold_convert (integer_type_node, argse.expr)));
2161 0 : gfc_add_block_to_block (&se->pre, &argse.pre);
2162 0 : gfc_add_block_to_block (&se->post, &argse.post);
2163 : }
2164 :
2165 : /* Fortran 2008 does not require that the values remain in the cobounds,
2166 : thus we need explicitly check this - and return 0 if they are exceeded. */
2167 :
2168 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2169 193 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2170 193 : invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2171 : fold_convert (gfc_array_index_type, tmp),
2172 : lbound);
2173 :
2174 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2175 : {
2176 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2177 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2178 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2179 250 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2180 : fold_convert (gfc_array_index_type, tmp),
2181 : lbound);
2182 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2183 : logical_type_node, invalid_bound, cond);
2184 250 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2185 : fold_convert (gfc_array_index_type, tmp),
2186 : ubound);
2187 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2188 : logical_type_node, invalid_bound, cond);
2189 : }
2190 :
2191 193 : invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2192 :
2193 : /* See Fortran 2008, C.10 for the following algorithm. */
2194 :
2195 : /* coindex = sub(corank) - lcobound(n). */
2196 193 : coindex = fold_convert (gfc_array_index_type,
2197 : gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2198 : NULL));
2199 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2200 193 : coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2201 : fold_convert (gfc_array_index_type, coindex),
2202 : lbound);
2203 :
2204 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2205 : {
2206 250 : tree extent, ubound;
2207 :
2208 : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2209 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2210 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2211 250 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2212 :
2213 : /* coindex *= extent. */
2214 250 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2215 : gfc_array_index_type, coindex, extent);
2216 :
2217 : /* coindex += sub(codim). */
2218 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2219 250 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2220 : gfc_array_index_type, coindex,
2221 : fold_convert (gfc_array_index_type, tmp));
2222 :
2223 : /* coindex -= lbound(codim). */
2224 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2225 250 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2226 : gfc_array_index_type, coindex, lbound);
2227 : }
2228 :
2229 193 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2230 : fold_convert(type, coindex),
2231 : build_int_cst (type, 1));
2232 :
2233 : /* Return 0 if "coindex" exceeds num_images(). */
2234 :
2235 193 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2236 108 : num_images = build_int_cst (type, 1);
2237 : else
2238 : {
2239 85 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2240 : team, team_number);
2241 85 : num_images = fold_convert (type, tmp);
2242 : }
2243 :
2244 193 : tmp = gfc_create_var (type, NULL);
2245 193 : gfc_add_modify (&se->pre, tmp, coindex);
2246 :
2247 193 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2248 : num_images);
2249 193 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2250 : cond,
2251 : fold_convert (logical_type_node, invalid_bound));
2252 193 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2253 : build_int_cst (type, 0), tmp);
2254 193 : }
2255 :
2256 : static void
2257 810 : trans_num_images (gfc_se * se, gfc_expr *expr)
2258 : {
2259 810 : tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2260 810 : gfc_se argse;
2261 :
2262 810 : if (expr->value.function.actual->expr)
2263 : {
2264 18 : gfc_init_se (&argse, NULL);
2265 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2266 18 : if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
2267 6 : team = argse.expr;
2268 : else
2269 12 : team_number = gfc_build_addr_expr (
2270 : NULL_TREE,
2271 : gfc_trans_force_lval (&se->pre,
2272 : fold_convert (integer_type_node, argse.expr)));
2273 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
2274 18 : gfc_add_block_to_block (&se->post, &argse.post);
2275 : }
2276 :
2277 810 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2278 : team, team_number);
2279 810 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2280 810 : }
2281 :
2282 :
2283 : static void
2284 12693 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2285 : {
2286 12693 : gfc_se argse;
2287 :
2288 12693 : gfc_init_se (&argse, NULL);
2289 12693 : argse.data_not_needed = 1;
2290 12693 : argse.descriptor_only = 1;
2291 :
2292 12693 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2293 12693 : gfc_add_block_to_block (&se->pre, &argse.pre);
2294 12693 : gfc_add_block_to_block (&se->post, &argse.post);
2295 :
2296 12693 : se->expr = gfc_conv_descriptor_rank (argse.expr);
2297 12693 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2298 : se->expr);
2299 12693 : }
2300 :
2301 :
2302 : static void
2303 735 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2304 : {
2305 735 : gfc_expr *arg;
2306 735 : arg = expr->value.function.actual->expr;
2307 735 : gfc_conv_is_contiguous_expr (se, arg);
2308 735 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2309 735 : }
2310 :
2311 : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2312 : plus it can be called directly. */
2313 :
2314 : void
2315 2077 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2316 : {
2317 2077 : gfc_ss *ss;
2318 2077 : gfc_se argse;
2319 2077 : tree desc, tmp, stride, extent, cond;
2320 2077 : int i;
2321 2077 : tree fncall0;
2322 2077 : gfc_array_spec *as;
2323 2077 : gfc_symbol *sym = NULL;
2324 :
2325 2077 : if (arg->ts.type == BT_CLASS)
2326 90 : gfc_add_class_array_ref (arg);
2327 :
2328 2077 : if (arg->expr_type == EXPR_VARIABLE)
2329 2041 : sym = arg->symtree->n.sym;
2330 :
2331 2077 : ss = gfc_walk_expr (arg);
2332 2077 : gcc_assert (ss != gfc_ss_terminator);
2333 2077 : gfc_init_se (&argse, NULL);
2334 2077 : argse.data_not_needed = 1;
2335 2077 : gfc_conv_expr_descriptor (&argse, arg);
2336 :
2337 2077 : as = gfc_get_full_arrayspec_from_expr (arg);
2338 :
2339 : /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2340 : Note in addition that zero-sized arrays don't count as contiguous. */
2341 :
2342 2077 : if (as && as->type == AS_ASSUMED_RANK)
2343 : {
2344 : /* Build the call to is_contiguous0. */
2345 243 : argse.want_pointer = 1;
2346 243 : gfc_conv_expr_descriptor (&argse, arg);
2347 243 : gfc_add_block_to_block (&se->pre, &argse.pre);
2348 243 : gfc_add_block_to_block (&se->post, &argse.post);
2349 243 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2350 243 : fncall0 = build_call_expr_loc (input_location,
2351 : gfor_fndecl_is_contiguous0, 1, desc);
2352 243 : se->expr = fncall0;
2353 243 : se->expr = convert (boolean_type_node, se->expr);
2354 : }
2355 : else
2356 : {
2357 1834 : gfc_add_block_to_block (&se->pre, &argse.pre);
2358 1834 : gfc_add_block_to_block (&se->post, &argse.post);
2359 1834 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2360 :
2361 1834 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2362 1834 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2363 1834 : stride, build_int_cst (TREE_TYPE (stride), 1));
2364 :
2365 2157 : for (i = 0; i < arg->rank - 1; i++)
2366 : {
2367 323 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2368 323 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2369 323 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2370 : gfc_array_index_type, extent, tmp);
2371 323 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2372 : gfc_array_index_type, extent,
2373 : gfc_index_one_node);
2374 323 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2375 323 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2376 : tmp, extent);
2377 323 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2378 323 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2379 : stride, tmp);
2380 323 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2381 : boolean_type_node, cond, tmp);
2382 : }
2383 1834 : se->expr = cond;
2384 : }
2385 :
2386 : /* A pointer that does not have the CONTIGUOUS attribute needs to be checked
2387 : if it points to an array whose span differs from the element size. */
2388 2077 : if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous)
2389 : {
2390 180 : tree span = gfc_conv_descriptor_span_get (desc);
2391 180 : tmp = fold_convert (TREE_TYPE (span),
2392 : gfc_conv_descriptor_elem_len (desc));
2393 180 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2394 : span, tmp);
2395 180 : se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2396 : boolean_type_node, cond,
2397 : convert (boolean_type_node, se->expr));
2398 : }
2399 :
2400 2077 : gfc_free_ss_chain (ss);
2401 2077 : }
2402 :
2403 :
2404 : /* Evaluate a single upper or lower bound. */
2405 : /* TODO: bound intrinsic generates way too much unnecessary code. */
2406 :
2407 : static void
2408 16237 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2409 : {
2410 16237 : gfc_actual_arglist *arg;
2411 16237 : gfc_actual_arglist *arg2;
2412 16237 : tree desc;
2413 16237 : tree type;
2414 16237 : tree bound;
2415 16237 : tree tmp;
2416 16237 : tree cond, cond1;
2417 16237 : tree ubound;
2418 16237 : tree lbound;
2419 16237 : tree size;
2420 16237 : gfc_se argse;
2421 16237 : gfc_array_spec * as;
2422 16237 : bool assumed_rank_lb_one;
2423 :
2424 16237 : arg = expr->value.function.actual;
2425 16237 : arg2 = arg->next;
2426 :
2427 16237 : if (se->ss)
2428 : {
2429 : /* Create an implicit second parameter from the loop variable. */
2430 7944 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2431 7944 : gcc_assert (se->loop->dimen == 1);
2432 7944 : gcc_assert (se->ss->info->expr == expr);
2433 7944 : gfc_advance_se_ss_chain (se);
2434 7944 : bound = se->loop->loopvar[0];
2435 7944 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2436 : gfc_array_index_type, bound,
2437 : se->loop->from[0]);
2438 : }
2439 : else
2440 : {
2441 : /* use the passed argument. */
2442 8293 : gcc_assert (arg2->expr);
2443 8293 : gfc_init_se (&argse, NULL);
2444 8293 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2445 8293 : gfc_add_block_to_block (&se->pre, &argse.pre);
2446 8293 : bound = argse.expr;
2447 : /* Convert from one based to zero based. */
2448 8293 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2449 : gfc_array_index_type, bound,
2450 : gfc_index_one_node);
2451 : }
2452 :
2453 : /* TODO: don't re-evaluate the descriptor on each iteration. */
2454 : /* Get a descriptor for the first parameter. */
2455 16237 : gfc_init_se (&argse, NULL);
2456 16237 : gfc_conv_expr_descriptor (&argse, arg->expr);
2457 16237 : gfc_add_block_to_block (&se->pre, &argse.pre);
2458 16237 : gfc_add_block_to_block (&se->post, &argse.post);
2459 :
2460 16237 : desc = argse.expr;
2461 :
2462 16237 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2463 :
2464 16237 : if (INTEGER_CST_P (bound))
2465 : {
2466 8173 : gcc_assert (op != GFC_ISYM_SHAPE);
2467 7936 : if (((!as || as->type != AS_ASSUMED_RANK)
2468 7265 : && wi::geu_p (wi::to_wide (bound),
2469 7265 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2470 16346 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2471 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2472 : "dimension index",
2473 : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2474 : &expr->where);
2475 : }
2476 :
2477 16237 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2478 : {
2479 8972 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2480 : {
2481 651 : bound = gfc_evaluate_now (bound, &se->pre);
2482 651 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2483 651 : bound, build_int_cst (TREE_TYPE (bound), 0));
2484 651 : if (as && as->type == AS_ASSUMED_RANK)
2485 546 : tmp = gfc_conv_descriptor_rank (desc);
2486 : else
2487 105 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2488 651 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2489 651 : bound, fold_convert(TREE_TYPE (bound), tmp));
2490 651 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2491 : logical_type_node, cond, tmp);
2492 651 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2493 : gfc_msg_fault);
2494 : }
2495 : }
2496 :
2497 : /* Take care of the lbound shift for assumed-rank arrays that are
2498 : nonallocatable and nonpointers. Those have a lbound of 1. */
2499 15653 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2500 11157 : && ((arg->expr->ts.type != BT_CLASS
2501 1987 : && !arg->expr->symtree->n.sym->attr.allocatable
2502 1644 : && !arg->expr->symtree->n.sym->attr.pointer)
2503 920 : || (arg->expr->ts.type == BT_CLASS
2504 198 : && !CLASS_DATA (arg->expr)->attr.allocatable
2505 162 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
2506 :
2507 16237 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2508 16237 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2509 16237 : size = fold_build2_loc (input_location, MINUS_EXPR,
2510 : gfc_array_index_type, ubound, lbound);
2511 16237 : size = fold_build2_loc (input_location, PLUS_EXPR,
2512 : gfc_array_index_type, size, gfc_index_one_node);
2513 :
2514 : /* 13.14.53: Result value for LBOUND
2515 :
2516 : Case (i): For an array section or for an array expression other than a
2517 : whole array or array structure component, LBOUND(ARRAY, DIM)
2518 : has the value 1. For a whole array or array structure
2519 : component, LBOUND(ARRAY, DIM) has the value:
2520 : (a) equal to the lower bound for subscript DIM of ARRAY if
2521 : dimension DIM of ARRAY does not have extent zero
2522 : or if ARRAY is an assumed-size array of rank DIM,
2523 : or (b) 1 otherwise.
2524 :
2525 : 13.14.113: Result value for UBOUND
2526 :
2527 : Case (i): For an array section or for an array expression other than a
2528 : whole array or array structure component, UBOUND(ARRAY, DIM)
2529 : has the value equal to the number of elements in the given
2530 : dimension; otherwise, it has a value equal to the upper bound
2531 : for subscript DIM of ARRAY if dimension DIM of ARRAY does
2532 : not have size zero and has value zero if dimension DIM has
2533 : size zero. */
2534 :
2535 16237 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2536 556 : se->expr = gfc_index_one_node;
2537 15681 : else if (as)
2538 : {
2539 15097 : if (op == GFC_ISYM_UBOUND)
2540 : {
2541 5395 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2542 : size, gfc_index_zero_node);
2543 10162 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2544 : gfc_array_index_type, cond,
2545 : (assumed_rank_lb_one ? size : ubound),
2546 : gfc_index_zero_node);
2547 : }
2548 9702 : else if (op == GFC_ISYM_LBOUND)
2549 : {
2550 4903 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2551 : size, gfc_index_zero_node);
2552 4903 : if (as->type == AS_ASSUMED_SIZE)
2553 : {
2554 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2555 : logical_type_node, bound,
2556 98 : build_int_cst (TREE_TYPE (bound),
2557 98 : arg->expr->rank - 1));
2558 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2559 : logical_type_node, cond, cond1);
2560 : }
2561 4903 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2562 : gfc_array_index_type, cond,
2563 : lbound, gfc_index_one_node);
2564 : }
2565 4799 : else if (op == GFC_ISYM_SHAPE)
2566 4799 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2567 : gfc_array_index_type, size,
2568 : gfc_index_zero_node);
2569 : else
2570 0 : gcc_unreachable ();
2571 :
2572 : /* According to F2018 16.9.172, para 5, an assumed rank object,
2573 : argument associated with and assumed size array, has the ubound
2574 : of the final dimension set to -1 and UBOUND must return this.
2575 : Similarly for the SHAPE intrinsic. */
2576 15097 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2577 : {
2578 835 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2579 835 : tree rank = fold_convert (gfc_array_index_type,
2580 : gfc_conv_descriptor_rank (desc));
2581 835 : rank = fold_build2_loc (input_location, PLUS_EXPR,
2582 : gfc_array_index_type, rank, minus_one);
2583 :
2584 : /* Fix the expression to stop it from becoming even more
2585 : complicated. */
2586 835 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
2587 :
2588 : /* Descriptors for assumed-size arrays have ubound = -1
2589 : in the last dimension. */
2590 835 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2591 : logical_type_node, ubound, minus_one);
2592 835 : cond = fold_build2_loc (input_location, EQ_EXPR,
2593 : logical_type_node, bound, rank);
2594 835 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2595 : logical_type_node, cond, cond1);
2596 835 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2597 : gfc_array_index_type, cond,
2598 : minus_one, se->expr);
2599 : }
2600 : }
2601 : else /* as is null; this is an old-fashioned 1-based array. */
2602 : {
2603 584 : if (op != GFC_ISYM_LBOUND)
2604 : {
2605 482 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2606 : gfc_array_index_type, size,
2607 : gfc_index_zero_node);
2608 : }
2609 : else
2610 102 : se->expr = gfc_index_one_node;
2611 : }
2612 :
2613 :
2614 16237 : type = gfc_typenode_for_spec (&expr->ts);
2615 16237 : se->expr = convert (type, se->expr);
2616 16237 : }
2617 :
2618 :
2619 : static void
2620 666 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2621 : {
2622 666 : gfc_actual_arglist *arg;
2623 666 : gfc_actual_arglist *arg2;
2624 666 : gfc_se argse;
2625 666 : tree bound, lbound, resbound, resbound2, desc, cond, tmp;
2626 666 : tree type;
2627 666 : int corank;
2628 :
2629 666 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2630 : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2631 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE
2632 : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2633 :
2634 666 : arg = expr->value.function.actual;
2635 666 : arg2 = arg->next;
2636 :
2637 666 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2638 666 : corank = arg->expr->corank;
2639 :
2640 666 : gfc_init_se (&argse, NULL);
2641 666 : argse.want_coarray = 1;
2642 :
2643 666 : gfc_conv_expr_descriptor (&argse, arg->expr);
2644 666 : gfc_add_block_to_block (&se->pre, &argse.pre);
2645 666 : gfc_add_block_to_block (&se->post, &argse.post);
2646 666 : desc = argse.expr;
2647 :
2648 666 : if (se->ss)
2649 : {
2650 : /* Create an implicit second parameter from the loop variable. */
2651 238 : gcc_assert (!arg2->expr
2652 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE);
2653 238 : gcc_assert (corank > 0);
2654 238 : gcc_assert (se->loop->dimen == 1);
2655 238 : gcc_assert (se->ss->info->expr == expr);
2656 :
2657 238 : bound = se->loop->loopvar[0];
2658 476 : bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2659 238 : bound, gfc_rank_cst[arg->expr->rank]);
2660 238 : gfc_advance_se_ss_chain (se);
2661 : }
2662 428 : else if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2663 0 : bound = gfc_index_zero_node;
2664 : else
2665 : {
2666 428 : gcc_assert (arg2->expr);
2667 428 : gfc_init_se (&argse, NULL);
2668 428 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2669 428 : gfc_add_block_to_block (&se->pre, &argse.pre);
2670 428 : bound = argse.expr;
2671 :
2672 428 : if (INTEGER_CST_P (bound))
2673 : {
2674 334 : if (wi::ltu_p (wi::to_wide (bound), 1)
2675 668 : || wi::gtu_p (wi::to_wide (bound),
2676 334 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2677 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2678 0 : "dimension index", expr->value.function.isym->name,
2679 : &expr->where);
2680 : }
2681 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2682 : {
2683 36 : bound = gfc_evaluate_now (bound, &se->pre);
2684 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2685 36 : bound, build_int_cst (TREE_TYPE (bound), 1));
2686 36 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2687 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2688 : bound, tmp);
2689 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2690 : logical_type_node, cond, tmp);
2691 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2692 : gfc_msg_fault);
2693 : }
2694 :
2695 :
2696 : /* Subtract 1 to get to zero based and add dimensions. */
2697 428 : switch (arg->expr->rank)
2698 : {
2699 70 : case 0:
2700 70 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2701 : gfc_array_index_type, bound,
2702 : gfc_index_one_node);
2703 : case 1:
2704 : break;
2705 38 : default:
2706 38 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2707 : gfc_array_index_type, bound,
2708 38 : gfc_rank_cst[arg->expr->rank - 1]);
2709 : }
2710 : }
2711 :
2712 666 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2713 :
2714 : /* COSHAPE needs the lower cobound and so it is stashed here before resbound
2715 : is overwritten. */
2716 666 : lbound = NULL_TREE;
2717 666 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2718 4 : lbound = resbound;
2719 :
2720 : /* Handle UCOBOUND with special handling of the last codimension. */
2721 666 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2722 422 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2723 : {
2724 : /* Last codimension: For -fcoarray=single just return
2725 : the lcobound - otherwise add
2726 : ceiling (real (num_images ()) / real (size)) - 1
2727 : = (num_images () + size - 1) / size - 1
2728 : = (num_images - 1) / size(),
2729 : where size is the product of the extent of all but the last
2730 : codimension. */
2731 :
2732 248 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2733 : {
2734 64 : tree cosize;
2735 :
2736 64 : cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2737 64 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2738 : 2, null_pointer_node, null_pointer_node);
2739 64 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2740 : gfc_array_index_type,
2741 : fold_convert (gfc_array_index_type, tmp),
2742 : build_int_cst (gfc_array_index_type, 1));
2743 64 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2744 : gfc_array_index_type, tmp,
2745 : fold_convert (gfc_array_index_type, cosize));
2746 64 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2747 : gfc_array_index_type, resbound, tmp);
2748 64 : }
2749 184 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2750 : {
2751 : /* ubound = lbound + num_images() - 1. */
2752 44 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2753 : 2, null_pointer_node, null_pointer_node);
2754 44 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2755 : gfc_array_index_type,
2756 : fold_convert (gfc_array_index_type, tmp),
2757 : build_int_cst (gfc_array_index_type, 1));
2758 44 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2759 : gfc_array_index_type, resbound, tmp);
2760 : }
2761 :
2762 248 : if (corank > 1)
2763 : {
2764 171 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2765 : bound,
2766 171 : build_int_cst (TREE_TYPE (bound),
2767 171 : arg->expr->rank + corank - 1));
2768 :
2769 171 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2770 171 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2771 : gfc_array_index_type, cond,
2772 : resbound, resbound2);
2773 : }
2774 : else
2775 77 : se->expr = resbound;
2776 :
2777 : /* Get the coshape for this dimension. */
2778 248 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2779 : {
2780 4 : gcc_assert (lbound != NULL_TREE);
2781 4 : se->expr = fold_build2_loc (input_location, MINUS_EXPR,
2782 : gfc_array_index_type,
2783 : se->expr, lbound);
2784 4 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2785 : gfc_array_index_type,
2786 : se->expr, gfc_index_one_node);
2787 : }
2788 : }
2789 : else
2790 418 : se->expr = resbound;
2791 :
2792 666 : type = gfc_typenode_for_spec (&expr->ts);
2793 666 : se->expr = convert (type, se->expr);
2794 666 : }
2795 :
2796 :
2797 : static void
2798 2302 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2799 : {
2800 2302 : gfc_actual_arglist *array_arg;
2801 2302 : gfc_actual_arglist *dim_arg;
2802 2302 : gfc_se argse;
2803 2302 : tree desc, tmp;
2804 :
2805 2302 : array_arg = expr->value.function.actual;
2806 2302 : dim_arg = array_arg->next;
2807 :
2808 2302 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2809 :
2810 2302 : gfc_init_se (&argse, NULL);
2811 2302 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2812 2302 : gfc_add_block_to_block (&se->pre, &argse.pre);
2813 2302 : gfc_add_block_to_block (&se->post, &argse.post);
2814 2302 : desc = argse.expr;
2815 :
2816 2302 : gcc_assert (dim_arg->expr);
2817 2302 : gfc_init_se (&argse, NULL);
2818 2302 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2819 2302 : gfc_add_block_to_block (&se->pre, &argse.pre);
2820 2302 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2821 : argse.expr, gfc_index_one_node);
2822 2302 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2823 2302 : }
2824 :
2825 : static void
2826 7932 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2827 : {
2828 7932 : tree arg, cabs;
2829 :
2830 7932 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2831 :
2832 7932 : switch (expr->value.function.actual->expr->ts.type)
2833 : {
2834 6926 : case BT_INTEGER:
2835 6926 : case BT_REAL:
2836 6926 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2837 : arg);
2838 6926 : break;
2839 :
2840 1006 : case BT_COMPLEX:
2841 1006 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2842 1006 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2843 1006 : break;
2844 :
2845 0 : default:
2846 0 : gcc_unreachable ();
2847 : }
2848 7932 : }
2849 :
2850 :
2851 : /* Create a complex value from one or two real components. */
2852 :
2853 : static void
2854 491 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2855 : {
2856 491 : tree real;
2857 491 : tree imag;
2858 491 : tree type;
2859 491 : tree *args;
2860 491 : unsigned int num_args;
2861 :
2862 491 : num_args = gfc_intrinsic_argument_list_length (expr);
2863 491 : args = XALLOCAVEC (tree, num_args);
2864 :
2865 491 : type = gfc_typenode_for_spec (&expr->ts);
2866 491 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2867 491 : real = convert (TREE_TYPE (type), args[0]);
2868 491 : if (both)
2869 447 : imag = convert (TREE_TYPE (type), args[1]);
2870 44 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2871 : {
2872 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2873 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2874 30 : imag = convert (TREE_TYPE (type), imag);
2875 : }
2876 : else
2877 14 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2878 :
2879 491 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2880 491 : }
2881 :
2882 :
2883 : /* Remainder function MOD(A, P) = A - INT(A / P) * P
2884 : MODULO(A, P) = A - FLOOR (A / P) * P
2885 :
2886 : The obvious algorithms above are numerically instable for large
2887 : arguments, hence these intrinsics are instead implemented via calls
2888 : to the fmod family of functions. It is the responsibility of the
2889 : user to ensure that the second argument is non-zero. */
2890 :
2891 : static void
2892 3684 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2893 : {
2894 3684 : tree type;
2895 3684 : tree tmp;
2896 3684 : tree test;
2897 3684 : tree test2;
2898 3684 : tree fmod;
2899 3684 : tree zero;
2900 3684 : tree args[2];
2901 :
2902 3684 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2903 :
2904 3684 : switch (expr->ts.type)
2905 : {
2906 3531 : case BT_INTEGER:
2907 : /* Integer case is easy, we've got a builtin op. */
2908 3531 : type = TREE_TYPE (args[0]);
2909 :
2910 3531 : if (modulo)
2911 411 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2912 : args[0], args[1]);
2913 : else
2914 3120 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2915 : args[0], args[1]);
2916 : break;
2917 :
2918 30 : case BT_UNSIGNED:
2919 : /* Even easier, we only need one. */
2920 30 : type = TREE_TYPE (args[0]);
2921 30 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2922 : args[0], args[1]);
2923 30 : break;
2924 :
2925 123 : case BT_REAL:
2926 123 : fmod = NULL_TREE;
2927 : /* Check if we have a builtin fmod. */
2928 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
2929 :
2930 : /* The builtin should always be available. */
2931 123 : gcc_assert (fmod != NULL_TREE);
2932 :
2933 123 : tmp = build_addr (fmod);
2934 123 : se->expr = build_call_array_loc (input_location,
2935 123 : TREE_TYPE (TREE_TYPE (fmod)),
2936 : tmp, 2, args);
2937 123 : if (modulo == 0)
2938 123 : return;
2939 :
2940 25 : type = TREE_TYPE (args[0]);
2941 :
2942 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
2943 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
2944 :
2945 : /* Definition:
2946 : modulo = arg - floor (arg/arg2) * arg2
2947 :
2948 : In order to calculate the result accurately, we use the fmod
2949 : function as follows.
2950 :
2951 : res = fmod (arg, arg2);
2952 : if (res)
2953 : {
2954 : if ((arg < 0) xor (arg2 < 0))
2955 : res += arg2;
2956 : }
2957 : else
2958 : res = copysign (0., arg2);
2959 :
2960 : => As two nested ternary exprs:
2961 :
2962 : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2963 : : copysign (0., arg2);
2964 :
2965 : */
2966 :
2967 25 : zero = gfc_build_const (type, integer_zero_node);
2968 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
2969 25 : if (!flag_signed_zeros)
2970 : {
2971 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2972 : args[0], zero);
2973 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2974 : args[1], zero);
2975 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2976 : logical_type_node, test, test2);
2977 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2978 : tmp, zero);
2979 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2980 : logical_type_node, test, test2);
2981 1 : test = gfc_evaluate_now (test, &se->pre);
2982 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2983 : fold_build2_loc (input_location,
2984 : PLUS_EXPR,
2985 : type, tmp, args[1]),
2986 : tmp);
2987 : }
2988 : else
2989 : {
2990 24 : tree expr1, copysign, cscall;
2991 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
2992 : expr->ts.kind);
2993 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2994 : args[0], zero);
2995 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2996 : args[1], zero);
2997 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2998 : logical_type_node, test, test2);
2999 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3000 : fold_build2_loc (input_location,
3001 : PLUS_EXPR,
3002 : type, tmp, args[1]),
3003 : tmp);
3004 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3005 : tmp, zero);
3006 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3007 : args[1]);
3008 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3009 : expr1, cscall);
3010 : }
3011 : return;
3012 :
3013 0 : default:
3014 0 : gcc_unreachable ();
3015 : }
3016 : }
3017 :
3018 : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3019 : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3020 : where the right shifts are logical (i.e. 0's are shifted in).
3021 : Because SHIFT_EXPR's want shifts strictly smaller than the integral
3022 : type width, we have to special-case both S == 0 and S == BITSIZE(J):
3023 : DSHIFTL(I,J,0) = I
3024 : DSHIFTL(I,J,BITSIZE) = J
3025 : DSHIFTR(I,J,0) = J
3026 : DSHIFTR(I,J,BITSIZE) = I. */
3027 :
3028 : static void
3029 132 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3030 : {
3031 132 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3032 132 : tree args[3], cond, tmp;
3033 132 : int bitsize;
3034 :
3035 132 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3036 :
3037 132 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3038 132 : type = TREE_TYPE (args[0]);
3039 132 : bitsize = TYPE_PRECISION (type);
3040 132 : utype = unsigned_type_for (type);
3041 132 : stype = TREE_TYPE (args[2]);
3042 :
3043 132 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3044 132 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3045 132 : shift = gfc_evaluate_now (args[2], &se->pre);
3046 :
3047 : /* The generic case. */
3048 132 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3049 132 : build_int_cst (stype, bitsize), shift);
3050 198 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3051 : arg1, dshiftl ? shift : tmp);
3052 :
3053 198 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3054 : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3055 132 : right = fold_convert (type, right);
3056 :
3057 132 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3058 :
3059 : /* Special cases. */
3060 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3061 : build_int_cst (stype, 0));
3062 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3063 : dshiftl ? arg1 : arg2, res);
3064 :
3065 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3066 132 : build_int_cst (stype, bitsize));
3067 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3068 : dshiftl ? arg2 : arg1, res);
3069 :
3070 132 : se->expr = res;
3071 132 : }
3072 :
3073 :
3074 : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3075 :
3076 : static void
3077 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3078 : {
3079 96 : tree val;
3080 96 : tree tmp;
3081 96 : tree type;
3082 96 : tree zero;
3083 96 : tree args[2];
3084 :
3085 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3086 96 : type = TREE_TYPE (args[0]);
3087 :
3088 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3089 96 : val = gfc_evaluate_now (val, &se->pre);
3090 :
3091 96 : zero = gfc_build_const (type, integer_zero_node);
3092 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3093 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3094 96 : }
3095 :
3096 :
3097 : /* SIGN(A, B) is absolute value of A times sign of B.
3098 : The real value versions use library functions to ensure the correct
3099 : handling of negative zero. Integer case implemented as:
3100 : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3101 : */
3102 :
3103 : static void
3104 423 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3105 : {
3106 423 : tree tmp;
3107 423 : tree type;
3108 423 : tree args[2];
3109 :
3110 423 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3111 423 : if (expr->ts.type == BT_REAL)
3112 : {
3113 161 : tree abs;
3114 :
3115 161 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3116 161 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3117 :
3118 : /* We explicitly have to ignore the minus sign. We do so by using
3119 : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3120 161 : if (!flag_sign_zero
3121 197 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3122 : {
3123 12 : tree cond, zero;
3124 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3125 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3126 : args[1], zero);
3127 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3128 12 : TREE_TYPE (args[0]), cond,
3129 : build_call_expr_loc (input_location, abs, 1,
3130 : args[0]),
3131 : build_call_expr_loc (input_location, tmp, 2,
3132 : args[0], args[1]));
3133 : }
3134 : else
3135 149 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3136 : args[0], args[1]);
3137 161 : return;
3138 : }
3139 :
3140 : /* Having excluded floating point types, we know we are now dealing
3141 : with signed integer types. */
3142 262 : type = TREE_TYPE (args[0]);
3143 :
3144 : /* Args[0] is used multiple times below. */
3145 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3146 :
3147 : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3148 : the signs of A and B are the same, and of all ones if they differ. */
3149 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3150 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3151 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3152 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3153 :
3154 : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3155 : is all ones (i.e. -1). */
3156 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3157 : fold_build2_loc (input_location, PLUS_EXPR,
3158 : type, args[0], tmp), tmp);
3159 : }
3160 :
3161 :
3162 : /* Test for the presence of an optional argument. */
3163 :
3164 : static void
3165 5070 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3166 : {
3167 5070 : gfc_expr *arg;
3168 :
3169 5070 : arg = expr->value.function.actual->expr;
3170 5070 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3171 5070 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3172 5070 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3173 5070 : }
3174 :
3175 :
3176 : /* Calculate the double precision product of two single precision values. */
3177 :
3178 : static void
3179 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3180 : {
3181 13 : tree type;
3182 13 : tree args[2];
3183 :
3184 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3185 :
3186 : /* Convert the args to double precision before multiplying. */
3187 13 : type = gfc_typenode_for_spec (&expr->ts);
3188 13 : args[0] = convert (type, args[0]);
3189 13 : args[1] = convert (type, args[1]);
3190 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3191 : args[1]);
3192 13 : }
3193 :
3194 :
3195 : /* Return a length one character string containing an ascii character. */
3196 :
3197 : static void
3198 2020 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3199 : {
3200 2020 : tree arg[2];
3201 2020 : tree var;
3202 2020 : tree type;
3203 2020 : unsigned int num_args;
3204 :
3205 2020 : num_args = gfc_intrinsic_argument_list_length (expr);
3206 2020 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3207 :
3208 2020 : type = gfc_get_char_type (expr->ts.kind);
3209 2020 : var = gfc_create_var (type, "char");
3210 :
3211 2020 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3212 2020 : gfc_add_modify (&se->pre, var, arg[0]);
3213 2020 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3214 2020 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3215 2020 : }
3216 :
3217 :
3218 : static void
3219 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3220 : {
3221 0 : tree var;
3222 0 : tree len;
3223 0 : tree tmp;
3224 0 : tree cond;
3225 0 : tree fndecl;
3226 0 : tree *args;
3227 0 : unsigned int num_args;
3228 :
3229 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3230 0 : args = XALLOCAVEC (tree, num_args);
3231 :
3232 0 : var = gfc_create_var (pchar_type_node, "pstr");
3233 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3234 :
3235 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3236 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3237 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3238 :
3239 0 : fndecl = build_addr (gfor_fndecl_ctime);
3240 0 : tmp = build_call_array_loc (input_location,
3241 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3242 : fndecl, num_args, args);
3243 0 : gfc_add_expr_to_block (&se->pre, tmp);
3244 :
3245 : /* Free the temporary afterwards, if necessary. */
3246 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3247 0 : len, build_int_cst (TREE_TYPE (len), 0));
3248 0 : tmp = gfc_call_free (var);
3249 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3250 0 : gfc_add_expr_to_block (&se->post, tmp);
3251 :
3252 0 : se->expr = var;
3253 0 : se->string_length = len;
3254 0 : }
3255 :
3256 :
3257 : static void
3258 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3259 : {
3260 0 : tree var;
3261 0 : tree len;
3262 0 : tree tmp;
3263 0 : tree cond;
3264 0 : tree fndecl;
3265 0 : tree *args;
3266 0 : unsigned int num_args;
3267 :
3268 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3269 0 : args = XALLOCAVEC (tree, num_args);
3270 :
3271 0 : var = gfc_create_var (pchar_type_node, "pstr");
3272 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3273 :
3274 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3275 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3276 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3277 :
3278 0 : fndecl = build_addr (gfor_fndecl_fdate);
3279 0 : tmp = build_call_array_loc (input_location,
3280 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3281 : fndecl, num_args, args);
3282 0 : gfc_add_expr_to_block (&se->pre, tmp);
3283 :
3284 : /* Free the temporary afterwards, if necessary. */
3285 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3286 0 : len, build_int_cst (TREE_TYPE (len), 0));
3287 0 : tmp = gfc_call_free (var);
3288 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3289 0 : gfc_add_expr_to_block (&se->post, tmp);
3290 :
3291 0 : se->expr = var;
3292 0 : se->string_length = len;
3293 0 : }
3294 :
3295 :
3296 : /* Generate a direct call to free() for the FREE subroutine. */
3297 :
3298 : static tree
3299 10 : conv_intrinsic_free (gfc_code *code)
3300 : {
3301 10 : stmtblock_t block;
3302 10 : gfc_se argse;
3303 10 : tree arg, call;
3304 :
3305 10 : gfc_init_se (&argse, NULL);
3306 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3307 10 : arg = fold_convert (ptr_type_node, argse.expr);
3308 :
3309 10 : gfc_init_block (&block);
3310 10 : call = build_call_expr_loc (input_location,
3311 : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3312 10 : gfc_add_expr_to_block (&block, call);
3313 10 : return gfc_finish_block (&block);
3314 : }
3315 :
3316 :
3317 : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3318 : handling seeding on coarray images. */
3319 :
3320 : static tree
3321 90 : conv_intrinsic_random_init (gfc_code *code)
3322 : {
3323 90 : stmtblock_t block;
3324 90 : gfc_se se;
3325 90 : tree arg1, arg2, tmp;
3326 : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3327 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3328 90 : ? logical_type_node
3329 90 : : gfc_get_logical_type (4);
3330 :
3331 : /* Make the function call. */
3332 90 : gfc_init_block (&block);
3333 90 : gfc_init_se (&se, NULL);
3334 :
3335 : /* Convert REPEATABLE to the desired LOGICAL entity. */
3336 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3337 90 : gfc_add_block_to_block (&block, &se.pre);
3338 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3339 90 : gfc_add_block_to_block (&block, &se.post);
3340 :
3341 : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3342 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3343 90 : gfc_add_block_to_block (&block, &se.pre);
3344 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3345 90 : gfc_add_block_to_block (&block, &se.post);
3346 :
3347 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3348 : {
3349 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3350 : 2, arg1, arg2);
3351 : }
3352 : else
3353 : {
3354 : /* The ABI for libgfortran needs to be maintained, so a hidden
3355 : argument must be include if code is compiled with -fcoarray=single
3356 : or without the option. Set to 0. */
3357 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3358 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3359 : 3, arg1, arg2, arg3);
3360 : }
3361 :
3362 90 : gfc_add_expr_to_block (&block, tmp);
3363 :
3364 90 : return gfc_finish_block (&block);
3365 : }
3366 :
3367 :
3368 : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3369 : conversions. */
3370 :
3371 : static tree
3372 194 : conv_intrinsic_system_clock (gfc_code *code)
3373 : {
3374 194 : stmtblock_t block;
3375 194 : gfc_se count_se, count_rate_se, count_max_se;
3376 194 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3377 194 : tree tmp;
3378 194 : int least;
3379 :
3380 194 : gfc_expr *count = code->ext.actual->expr;
3381 194 : gfc_expr *count_rate = code->ext.actual->next->expr;
3382 194 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3383 :
3384 : /* Evaluate our arguments. */
3385 194 : if (count)
3386 : {
3387 194 : gfc_init_se (&count_se, NULL);
3388 194 : gfc_conv_expr (&count_se, count);
3389 : }
3390 :
3391 194 : if (count_rate)
3392 : {
3393 181 : gfc_init_se (&count_rate_se, NULL);
3394 181 : gfc_conv_expr (&count_rate_se, count_rate);
3395 : }
3396 :
3397 194 : if (count_max)
3398 : {
3399 180 : gfc_init_se (&count_max_se, NULL);
3400 180 : gfc_conv_expr (&count_max_se, count_max);
3401 : }
3402 :
3403 : /* Find the smallest kind found of the arguments. */
3404 194 : least = 16;
3405 194 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3406 194 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3407 : : least;
3408 194 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3409 : : least;
3410 :
3411 : /* Prepare temporary variables. */
3412 :
3413 194 : if (count)
3414 : {
3415 194 : if (least >= 8)
3416 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3417 176 : else if (least == 4)
3418 152 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3419 24 : else if (count->ts.kind == 1)
3420 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3421 : count->ts.kind);
3422 : else
3423 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3424 : count->ts.kind);
3425 : }
3426 :
3427 194 : if (count_rate)
3428 : {
3429 181 : if (least >= 8)
3430 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3431 163 : else if (least == 4)
3432 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3433 : else
3434 24 : arg2 = integer_zero_node;
3435 : }
3436 :
3437 194 : if (count_max)
3438 : {
3439 180 : if (least >= 8)
3440 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3441 162 : else if (least == 4)
3442 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3443 : else
3444 24 : arg3 = integer_zero_node;
3445 : }
3446 :
3447 : /* Make the function call. */
3448 194 : gfc_init_block (&block);
3449 :
3450 194 : if (least <= 2)
3451 : {
3452 24 : if (least == 1)
3453 : {
3454 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3455 : : null_pointer_node;
3456 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3457 : : null_pointer_node;
3458 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3459 : : null_pointer_node;
3460 : }
3461 :
3462 24 : if (least == 2)
3463 : {
3464 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3465 : : null_pointer_node;
3466 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3467 : : null_pointer_node;
3468 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3469 : : null_pointer_node;
3470 : }
3471 : }
3472 : else
3473 : {
3474 170 : if (least == 4)
3475 : {
3476 581 : tmp = build_call_expr_loc (input_location,
3477 : gfor_fndecl_system_clock4, 3,
3478 152 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3479 : : null_pointer_node,
3480 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3481 : : null_pointer_node,
3482 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3483 : : null_pointer_node);
3484 152 : gfc_add_expr_to_block (&block, tmp);
3485 : }
3486 : /* Handle kind>=8, 10, or 16 arguments */
3487 170 : if (least >= 8)
3488 : {
3489 72 : tmp = build_call_expr_loc (input_location,
3490 : gfor_fndecl_system_clock8, 3,
3491 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3492 : : null_pointer_node,
3493 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3494 : : null_pointer_node,
3495 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3496 : : null_pointer_node);
3497 18 : gfc_add_expr_to_block (&block, tmp);
3498 : }
3499 : }
3500 :
3501 : /* And store values back if needed. */
3502 194 : if (arg1 && arg1 != count_se.expr)
3503 194 : gfc_add_modify (&block, count_se.expr,
3504 194 : fold_convert (TREE_TYPE (count_se.expr), arg1));
3505 194 : if (arg2 && arg2 != count_rate_se.expr)
3506 181 : gfc_add_modify (&block, count_rate_se.expr,
3507 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3508 194 : if (arg3 && arg3 != count_max_se.expr)
3509 180 : gfc_add_modify (&block, count_max_se.expr,
3510 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3511 :
3512 194 : return gfc_finish_block (&block);
3513 : }
3514 :
3515 : static tree
3516 102 : conv_intrinsic_split (gfc_code *code)
3517 : {
3518 102 : stmtblock_t block, post_block;
3519 102 : gfc_se se;
3520 102 : gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3521 102 : tree string, string_len;
3522 102 : tree set, set_len;
3523 102 : tree pos, pos_for_call;
3524 102 : tree back;
3525 102 : tree fndecl, call;
3526 :
3527 102 : string_expr = code->ext.actual->expr;
3528 102 : set_expr = code->ext.actual->next->expr;
3529 102 : pos_expr = code->ext.actual->next->next->expr;
3530 102 : back_expr = code->ext.actual->next->next->next->expr;
3531 :
3532 102 : gfc_start_block (&block);
3533 102 : gfc_init_block (&post_block);
3534 :
3535 102 : gfc_init_se (&se, NULL);
3536 102 : gfc_conv_expr (&se, string_expr);
3537 102 : gfc_conv_string_parameter (&se);
3538 102 : gfc_add_block_to_block (&block, &se.pre);
3539 102 : gfc_add_block_to_block (&post_block, &se.post);
3540 102 : string = se.expr;
3541 102 : string_len = se.string_length;
3542 :
3543 102 : gfc_init_se (&se, NULL);
3544 102 : gfc_conv_expr (&se, set_expr);
3545 102 : gfc_conv_string_parameter (&se);
3546 102 : gfc_add_block_to_block (&block, &se.pre);
3547 102 : gfc_add_block_to_block (&post_block, &se.post);
3548 102 : set = se.expr;
3549 102 : set_len = se.string_length;
3550 :
3551 102 : gfc_init_se (&se, NULL);
3552 102 : gfc_conv_expr (&se, pos_expr);
3553 102 : gfc_add_block_to_block (&block, &se.pre);
3554 102 : gfc_add_block_to_block (&post_block, &se.post);
3555 102 : pos = se.expr;
3556 102 : pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3557 :
3558 102 : if (back_expr)
3559 : {
3560 48 : gfc_init_se (&se, NULL);
3561 48 : gfc_conv_expr (&se, back_expr);
3562 48 : gfc_add_block_to_block (&block, &se.pre);
3563 48 : gfc_add_block_to_block (&post_block, &se.post);
3564 48 : back = se.expr;
3565 : }
3566 : else
3567 54 : back = logical_false_node;
3568 :
3569 102 : if (string_expr->ts.kind == 1)
3570 66 : fndecl = gfor_fndecl_string_split;
3571 36 : else if (string_expr->ts.kind == 4)
3572 36 : fndecl = gfor_fndecl_string_split_char4;
3573 : else
3574 0 : gcc_unreachable ();
3575 :
3576 102 : call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3577 : set_len, set, pos_for_call, back);
3578 102 : gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3579 :
3580 102 : gfc_add_block_to_block (&block, &post_block);
3581 102 : return gfc_finish_block (&block);
3582 : }
3583 :
3584 : /* Return a character string containing the tty name. */
3585 :
3586 : static void
3587 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3588 : {
3589 0 : tree var;
3590 0 : tree len;
3591 0 : tree tmp;
3592 0 : tree cond;
3593 0 : tree fndecl;
3594 0 : tree *args;
3595 0 : unsigned int num_args;
3596 :
3597 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3598 0 : args = XALLOCAVEC (tree, num_args);
3599 :
3600 0 : var = gfc_create_var (pchar_type_node, "pstr");
3601 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3602 :
3603 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3604 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3605 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3606 :
3607 0 : fndecl = build_addr (gfor_fndecl_ttynam);
3608 0 : tmp = build_call_array_loc (input_location,
3609 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3610 : fndecl, num_args, args);
3611 0 : gfc_add_expr_to_block (&se->pre, tmp);
3612 :
3613 : /* Free the temporary afterwards, if necessary. */
3614 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3615 0 : len, build_int_cst (TREE_TYPE (len), 0));
3616 0 : tmp = gfc_call_free (var);
3617 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3618 0 : gfc_add_expr_to_block (&se->post, tmp);
3619 :
3620 0 : se->expr = var;
3621 0 : se->string_length = len;
3622 0 : }
3623 :
3624 :
3625 : /* Get the minimum/maximum value of all the parameters.
3626 : minmax (a1, a2, a3, ...)
3627 : {
3628 : mvar = a1;
3629 : mvar = COMP (mvar, a2)
3630 : mvar = COMP (mvar, a3)
3631 : ...
3632 : return mvar;
3633 : }
3634 : Where COMP is MIN/MAX_EXPR for integral types or when we don't
3635 : care about NaNs, or IFN_FMIN/MAX when the target has support for
3636 : fast NaN-honouring min/max. When neither holds expand a sequence
3637 : of explicit comparisons. */
3638 :
3639 : /* TODO: Mismatching types can occur when specific names are used.
3640 : These should be handled during resolution. */
3641 : static void
3642 1365 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3643 : {
3644 1365 : tree tmp;
3645 1365 : tree mvar;
3646 1365 : tree val;
3647 1365 : tree *args;
3648 1365 : tree type;
3649 1365 : tree argtype;
3650 1365 : gfc_actual_arglist *argexpr;
3651 1365 : unsigned int i, nargs;
3652 :
3653 1365 : nargs = gfc_intrinsic_argument_list_length (expr);
3654 1365 : args = XALLOCAVEC (tree, nargs);
3655 :
3656 1365 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3657 1365 : type = gfc_typenode_for_spec (&expr->ts);
3658 :
3659 : /* Only evaluate the argument once. */
3660 1365 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3661 368 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3662 :
3663 : /* Determine suitable type of temporary, as a GNU extension allows
3664 : different argument kinds. */
3665 1365 : argtype = TREE_TYPE (args[0]);
3666 1365 : argexpr = expr->value.function.actual;
3667 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3668 : {
3669 1584 : tree tmptype = TREE_TYPE (args[i]);
3670 1584 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3671 1 : argtype = tmptype;
3672 : }
3673 1365 : mvar = gfc_create_var (argtype, "M");
3674 1365 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3675 :
3676 1365 : argexpr = expr->value.function.actual;
3677 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3678 : {
3679 1584 : tree cond = NULL_TREE;
3680 1584 : val = args[i];
3681 :
3682 : /* Handle absent optional arguments by ignoring the comparison. */
3683 1584 : if (argexpr->expr->expr_type == EXPR_VARIABLE
3684 920 : && argexpr->expr->symtree->n.sym->attr.optional
3685 45 : && INDIRECT_REF_P (val))
3686 : {
3687 84 : cond = fold_build2_loc (input_location,
3688 : NE_EXPR, logical_type_node,
3689 42 : TREE_OPERAND (val, 0),
3690 42 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3691 : }
3692 1542 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
3693 : /* Only evaluate the argument once. */
3694 599 : val = gfc_evaluate_now (val, &se->pre);
3695 :
3696 1584 : tree calc;
3697 : /* For floating point types, the question is what MAX(a, NaN) or
3698 : MIN(a, NaN) should return (where "a" is a normal number).
3699 : There are valid use case for returning either one, but the
3700 : Fortran standard doesn't specify which one should be chosen.
3701 : Also, there is no consensus among other tested compilers. In
3702 : short, it's a mess. So lets just do whatever is fastest. */
3703 1584 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3704 1584 : calc = fold_build2_loc (input_location, code, argtype,
3705 : convert (argtype, val), mvar);
3706 1584 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3707 :
3708 1584 : if (cond != NULL_TREE)
3709 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3710 : build_empty_stmt (input_location));
3711 1584 : gfc_add_expr_to_block (&se->pre, tmp);
3712 : }
3713 1365 : se->expr = convert (type, mvar);
3714 1365 : }
3715 :
3716 :
3717 : /* Generate library calls for MIN and MAX intrinsics for character
3718 : variables. */
3719 : static void
3720 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3721 : {
3722 282 : tree *args;
3723 282 : tree var, len, fndecl, tmp, cond, function;
3724 282 : unsigned int nargs;
3725 :
3726 282 : nargs = gfc_intrinsic_argument_list_length (expr);
3727 282 : args = XALLOCAVEC (tree, nargs + 4);
3728 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3729 :
3730 : /* Create the result variables. */
3731 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
3732 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
3733 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3734 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3735 282 : args[2] = build_int_cst (integer_type_node, op);
3736 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
3737 :
3738 282 : if (expr->ts.kind == 1)
3739 210 : function = gfor_fndecl_string_minmax;
3740 72 : else if (expr->ts.kind == 4)
3741 72 : function = gfor_fndecl_string_minmax_char4;
3742 : else
3743 0 : gcc_unreachable ();
3744 :
3745 : /* Make the function call. */
3746 282 : fndecl = build_addr (function);
3747 282 : tmp = build_call_array_loc (input_location,
3748 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
3749 : nargs + 4, args);
3750 282 : gfc_add_expr_to_block (&se->pre, tmp);
3751 :
3752 : /* Free the temporary afterwards, if necessary. */
3753 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3754 282 : len, build_int_cst (TREE_TYPE (len), 0));
3755 282 : tmp = gfc_call_free (var);
3756 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3757 282 : gfc_add_expr_to_block (&se->post, tmp);
3758 :
3759 282 : se->expr = var;
3760 282 : se->string_length = len;
3761 282 : }
3762 :
3763 :
3764 : /* Create a symbol node for this intrinsic. The symbol from the frontend
3765 : has the generic name. */
3766 :
3767 : static gfc_symbol *
3768 11285 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3769 : {
3770 11285 : gfc_symbol *sym;
3771 :
3772 : /* TODO: Add symbols for intrinsic function to the global namespace. */
3773 11285 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3774 11285 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3775 :
3776 11285 : sym->ts = expr->ts;
3777 11285 : if (sym->ts.type == BT_CHARACTER)
3778 1784 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3779 11285 : sym->attr.external = 1;
3780 11285 : sym->attr.function = 1;
3781 11285 : sym->attr.always_explicit = 1;
3782 11285 : sym->attr.proc = PROC_INTRINSIC;
3783 11285 : sym->attr.flavor = FL_PROCEDURE;
3784 11285 : sym->result = sym;
3785 11285 : if (expr->rank > 0)
3786 : {
3787 9891 : sym->attr.dimension = 1;
3788 9891 : sym->as = gfc_get_array_spec ();
3789 9891 : sym->as->type = AS_ASSUMED_SHAPE;
3790 9891 : sym->as->rank = expr->rank;
3791 : }
3792 :
3793 11285 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3794 : ignore_optional ? expr->value.function.actual
3795 : : NULL);
3796 :
3797 11285 : return sym;
3798 : }
3799 :
3800 : /* Remove empty actual arguments. */
3801 :
3802 : static void
3803 8277 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
3804 : {
3805 44456 : while (*ap)
3806 : {
3807 36179 : if ((*ap)->expr == NULL)
3808 : {
3809 11076 : gfc_actual_arglist *r = *ap;
3810 11076 : *ap = r->next;
3811 11076 : r->next = NULL;
3812 11076 : gfc_free_actual_arglist (r);
3813 : }
3814 : else
3815 25103 : ap = &((*ap)->next);
3816 : }
3817 8277 : }
3818 :
3819 : #define MAX_SPEC_ARG 12
3820 :
3821 : /* Make up an fn spec that's right for intrinsic functions that we
3822 : want to call. */
3823 :
3824 : static char *
3825 1939 : intrinsic_fnspec (gfc_expr *expr)
3826 : {
3827 1939 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
3828 1939 : char *fp;
3829 1939 : int i;
3830 1939 : int num_char_args;
3831 :
3832 : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3833 :
3834 : /* Set the fndecl. */
3835 1939 : fp = fnspec_buf;
3836 : /* Function return value. FIXME: Check if the second letter could
3837 : be something other than a space, for further optimization. */
3838 1939 : ADD_CHAR ('.');
3839 1939 : if (expr->rank == 0)
3840 : {
3841 238 : if (expr->ts.type == BT_CHARACTER)
3842 : {
3843 84 : ADD_CHAR ('w'); /* Address of character. */
3844 84 : ADD_CHAR ('.'); /* Length of character. */
3845 : }
3846 : }
3847 : else
3848 1701 : ADD_CHAR ('w'); /* Return value is a descriptor. */
3849 :
3850 1939 : num_char_args = 0;
3851 10224 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3852 : {
3853 8285 : if (a->expr == NULL)
3854 2565 : continue;
3855 :
3856 5720 : if (a->name && strcmp (a->name,"%VAL") == 0)
3857 1300 : ADD_CHAR ('.');
3858 : else
3859 : {
3860 4420 : if (a->expr->rank > 0)
3861 2575 : ADD_CHAR ('r');
3862 : else
3863 1845 : ADD_CHAR ('R');
3864 : }
3865 5720 : num_char_args += a->expr->ts.type == BT_CHARACTER;
3866 5720 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3867 : }
3868 :
3869 2743 : for (i = 0; i < num_char_args; i++)
3870 804 : ADD_CHAR ('.');
3871 :
3872 1939 : *fp = '\0';
3873 1939 : return fnspec_buf;
3874 : }
3875 :
3876 : #undef MAX_SPEC_ARG
3877 : #undef ADD_CHAR
3878 :
3879 : /* Generate the right symbol for the specific intrinsic function and
3880 : modify the expr accordingly. This assumes that absent optional
3881 : arguments should be removed. */
3882 :
3883 : gfc_symbol *
3884 8277 : specific_intrinsic_symbol (gfc_expr *expr)
3885 : {
3886 8277 : gfc_symbol *sym;
3887 :
3888 8277 : sym = gfc_find_intrinsic_symbol (expr);
3889 8277 : if (sym == NULL)
3890 : {
3891 1939 : sym = gfc_get_intrinsic_function_symbol (expr);
3892 1939 : sym->ts = expr->ts;
3893 1939 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3894 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3895 :
3896 1939 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3897 : expr->value.function.actual, true);
3898 1939 : sym->backend_decl
3899 1939 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
3900 1939 : intrinsic_fnspec (expr));
3901 : }
3902 :
3903 8277 : remove_empty_actual_arguments (&(expr->value.function.actual));
3904 :
3905 8277 : return sym;
3906 : }
3907 :
3908 : /* Generate a call to an external intrinsic function. FIXME: So far,
3909 : this only works for functions which are called with well-defined
3910 : types; CSHIFT and friends will come later. */
3911 :
3912 : static void
3913 13719 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3914 : {
3915 13719 : gfc_symbol *sym;
3916 13719 : vec<tree, va_gc> *append_args;
3917 13719 : bool specific_symbol;
3918 :
3919 13719 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3920 :
3921 13719 : if (se->ss)
3922 11763 : gcc_assert (expr->rank > 0);
3923 : else
3924 1956 : gcc_assert (expr->rank == 0);
3925 :
3926 13719 : switch (expr->value.function.isym->id)
3927 : {
3928 : case GFC_ISYM_ANY:
3929 : case GFC_ISYM_ALL:
3930 : case GFC_ISYM_FINDLOC:
3931 : case GFC_ISYM_MAXLOC:
3932 : case GFC_ISYM_MINLOC:
3933 : case GFC_ISYM_MAXVAL:
3934 : case GFC_ISYM_MINVAL:
3935 : case GFC_ISYM_NORM2:
3936 : case GFC_ISYM_PRODUCT:
3937 : case GFC_ISYM_SUM:
3938 : specific_symbol = true;
3939 : break;
3940 5442 : default:
3941 5442 : specific_symbol = false;
3942 : }
3943 :
3944 13719 : if (specific_symbol)
3945 : {
3946 : /* Need to copy here because specific_intrinsic_symbol modifies
3947 : expr to omit the absent optional arguments. */
3948 8277 : expr = gfc_copy_expr (expr);
3949 8277 : sym = specific_intrinsic_symbol (expr);
3950 : }
3951 : else
3952 5442 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3953 :
3954 : /* Calls to libgfortran_matmul need to be appended special arguments,
3955 : to be able to call the BLAS ?gemm functions if required and possible. */
3956 13719 : append_args = NULL;
3957 13719 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3958 866 : && !expr->external_blas
3959 828 : && sym->ts.type != BT_LOGICAL)
3960 : {
3961 812 : tree cint = gfc_get_int_type (gfc_c_int_kind);
3962 :
3963 812 : if (flag_external_blas
3964 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3965 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
3966 : {
3967 0 : tree gemm_fndecl;
3968 :
3969 0 : if (sym->ts.type == BT_REAL)
3970 : {
3971 0 : if (sym->ts.kind == 4)
3972 0 : gemm_fndecl = gfor_fndecl_sgemm;
3973 : else
3974 0 : gemm_fndecl = gfor_fndecl_dgemm;
3975 : }
3976 : else
3977 : {
3978 0 : if (sym->ts.kind == 4)
3979 0 : gemm_fndecl = gfor_fndecl_cgemm;
3980 : else
3981 0 : gemm_fndecl = gfor_fndecl_zgemm;
3982 : }
3983 :
3984 0 : vec_alloc (append_args, 3);
3985 0 : append_args->quick_push (build_int_cst (cint, 1));
3986 0 : append_args->quick_push (build_int_cst (cint,
3987 0 : flag_blas_matmul_limit));
3988 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3989 : gemm_fndecl));
3990 0 : }
3991 : else
3992 : {
3993 812 : vec_alloc (append_args, 3);
3994 812 : append_args->quick_push (build_int_cst (cint, 0));
3995 812 : append_args->quick_push (build_int_cst (cint, 0));
3996 812 : append_args->quick_push (null_pointer_node);
3997 : }
3998 : }
3999 : /* Non-character scalar reduce returns a pointer to a result of size set by
4000 : the element size of 'array'. Setting 'sym' allocatable ensures that the
4001 : result is deallocated at the appropriate time. */
4002 12907 : else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
4003 102 : && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
4004 96 : sym->attr.allocatable = 1;
4005 :
4006 :
4007 13719 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4008 : append_args);
4009 :
4010 13719 : if (specific_symbol)
4011 8277 : gfc_free_expr (expr);
4012 : else
4013 5442 : gfc_free_symbol (sym);
4014 13719 : }
4015 :
4016 : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4017 : Implemented as
4018 : any(a)
4019 : {
4020 : forall (i=...)
4021 : if (a[i] != 0)
4022 : return 1
4023 : end forall
4024 : return 0
4025 : }
4026 : all(a)
4027 : {
4028 : forall (i=...)
4029 : if (a[i] == 0)
4030 : return 0
4031 : end forall
4032 : return 1
4033 : }
4034 : */
4035 : static void
4036 38497 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4037 : {
4038 38497 : tree resvar;
4039 38497 : stmtblock_t block;
4040 38497 : stmtblock_t body;
4041 38497 : tree type;
4042 38497 : tree tmp;
4043 38497 : tree found;
4044 38497 : gfc_loopinfo loop;
4045 38497 : gfc_actual_arglist *actual;
4046 38497 : gfc_ss *arrayss;
4047 38497 : gfc_se arrayse;
4048 38497 : tree exit_label;
4049 :
4050 38497 : if (se->ss)
4051 : {
4052 0 : gfc_conv_intrinsic_funcall (se, expr);
4053 0 : return;
4054 : }
4055 :
4056 38497 : actual = expr->value.function.actual;
4057 38497 : type = gfc_typenode_for_spec (&expr->ts);
4058 : /* Initialize the result. */
4059 38497 : resvar = gfc_create_var (type, "test");
4060 38497 : if (op == EQ_EXPR)
4061 420 : tmp = convert (type, boolean_true_node);
4062 : else
4063 38077 : tmp = convert (type, boolean_false_node);
4064 38497 : gfc_add_modify (&se->pre, resvar, tmp);
4065 :
4066 : /* Walk the arguments. */
4067 38497 : arrayss = gfc_walk_expr (actual->expr);
4068 38497 : gcc_assert (arrayss != gfc_ss_terminator);
4069 :
4070 : /* Initialize the scalarizer. */
4071 38497 : gfc_init_loopinfo (&loop);
4072 38497 : exit_label = gfc_build_label_decl (NULL_TREE);
4073 38497 : TREE_USED (exit_label) = 1;
4074 38497 : gfc_add_ss_to_loop (&loop, arrayss);
4075 :
4076 : /* Initialize the loop. */
4077 38497 : gfc_conv_ss_startstride (&loop);
4078 38497 : gfc_conv_loop_setup (&loop, &expr->where);
4079 :
4080 38497 : gfc_mark_ss_chain_used (arrayss, 1);
4081 : /* Generate the loop body. */
4082 38497 : gfc_start_scalarized_body (&loop, &body);
4083 :
4084 : /* If the condition matches then set the return value. */
4085 38497 : gfc_start_block (&block);
4086 38497 : if (op == EQ_EXPR)
4087 420 : tmp = convert (type, boolean_false_node);
4088 : else
4089 38077 : tmp = convert (type, boolean_true_node);
4090 38497 : gfc_add_modify (&block, resvar, tmp);
4091 :
4092 : /* And break out of the loop. */
4093 38497 : tmp = build1_v (GOTO_EXPR, exit_label);
4094 38497 : gfc_add_expr_to_block (&block, tmp);
4095 :
4096 38497 : found = gfc_finish_block (&block);
4097 :
4098 : /* Check this element. */
4099 38497 : gfc_init_se (&arrayse, NULL);
4100 38497 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4101 38497 : arrayse.ss = arrayss;
4102 38497 : gfc_conv_expr_val (&arrayse, actual->expr);
4103 :
4104 38497 : gfc_add_block_to_block (&body, &arrayse.pre);
4105 38497 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4106 38497 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4107 38497 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4108 38497 : gfc_add_expr_to_block (&body, tmp);
4109 38497 : gfc_add_block_to_block (&body, &arrayse.post);
4110 :
4111 38497 : gfc_trans_scalarizing_loops (&loop, &body);
4112 :
4113 : /* Add the exit label. */
4114 38497 : tmp = build1_v (LABEL_EXPR, exit_label);
4115 38497 : gfc_add_expr_to_block (&loop.pre, tmp);
4116 :
4117 38497 : gfc_add_block_to_block (&se->pre, &loop.pre);
4118 38497 : gfc_add_block_to_block (&se->pre, &loop.post);
4119 38497 : gfc_cleanup_loop (&loop);
4120 :
4121 38497 : se->expr = resvar;
4122 : }
4123 :
4124 :
4125 : /* Generate the constant 180 / pi, which is used in the conversion
4126 : of acosd(), asind(), atand(), atan2d(). */
4127 :
4128 : static tree
4129 336 : rad2deg (int kind)
4130 : {
4131 336 : tree retval;
4132 336 : mpfr_t pi, t0;
4133 :
4134 336 : gfc_set_model_kind (kind);
4135 336 : mpfr_init (pi);
4136 336 : mpfr_init (t0);
4137 336 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4138 336 : mpfr_const_pi (pi, GFC_RND_MODE);
4139 336 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4140 336 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4141 336 : mpfr_clear (t0);
4142 336 : mpfr_clear (pi);
4143 336 : return retval;
4144 : }
4145 :
4146 :
4147 : static gfc_intrinsic_map_t *
4148 546 : gfc_lookup_intrinsic (gfc_isym_id id)
4149 : {
4150 546 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4151 11154 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4152 11154 : if (id == m->id)
4153 : break;
4154 546 : gcc_assert (id == m->id);
4155 546 : return m;
4156 : }
4157 :
4158 :
4159 : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4160 : ASIND(x) is translated into ASIN(x) * 180 / pi.
4161 : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4162 :
4163 : static void
4164 216 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4165 : {
4166 216 : tree arg;
4167 216 : tree atrigd;
4168 216 : tree type;
4169 216 : gfc_intrinsic_map_t *m;
4170 :
4171 216 : type = gfc_typenode_for_spec (&expr->ts);
4172 :
4173 216 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4174 :
4175 216 : switch (id)
4176 : {
4177 72 : case GFC_ISYM_ACOSD:
4178 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4179 72 : break;
4180 72 : case GFC_ISYM_ASIND:
4181 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4182 72 : break;
4183 72 : case GFC_ISYM_ATAND:
4184 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4185 72 : break;
4186 0 : default:
4187 0 : gcc_unreachable ();
4188 : }
4189 216 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4190 216 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4191 :
4192 216 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4193 : fold_convert (type, rad2deg (expr->ts.kind)));
4194 216 : }
4195 :
4196 :
4197 : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4198 : COS(X) / SIN(X) for COMPLEX argument. */
4199 :
4200 : static void
4201 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4202 : {
4203 102 : gfc_intrinsic_map_t *m;
4204 102 : tree arg;
4205 102 : tree type;
4206 :
4207 102 : type = gfc_typenode_for_spec (&expr->ts);
4208 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4209 :
4210 102 : if (expr->ts.type == BT_REAL)
4211 : {
4212 102 : tree tan;
4213 102 : tree tmp;
4214 102 : mpfr_t pio2;
4215 :
4216 : /* Create pi/2. */
4217 102 : gfc_set_model_kind (expr->ts.kind);
4218 102 : mpfr_init (pio2);
4219 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4220 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4221 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4222 102 : mpfr_clear (pio2);
4223 :
4224 : /* Find tan builtin function. */
4225 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4226 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4227 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4228 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4229 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4230 : }
4231 : else
4232 : {
4233 0 : tree sin;
4234 0 : tree cos;
4235 :
4236 : /* Find cos builtin function. */
4237 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4238 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4239 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4240 :
4241 : /* Find sin builtin function. */
4242 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4243 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4244 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4245 :
4246 : /* Divide cos by sin. */
4247 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4248 : }
4249 102 : }
4250 :
4251 :
4252 : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4253 :
4254 : static void
4255 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4256 : {
4257 108 : tree arg;
4258 108 : tree type;
4259 108 : tree ninety_tree;
4260 108 : mpfr_t ninety;
4261 :
4262 108 : type = gfc_typenode_for_spec (&expr->ts);
4263 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4264 :
4265 108 : gfc_set_model_kind (expr->ts.kind);
4266 :
4267 : /* Build the tree for x + 90. */
4268 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4269 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4270 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4271 108 : mpfr_clear (ninety);
4272 :
4273 : /* Find tand. */
4274 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4275 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4276 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4277 :
4278 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4279 108 : }
4280 :
4281 :
4282 : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4283 :
4284 : static void
4285 120 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4286 : {
4287 120 : tree args[2];
4288 120 : tree atan2d;
4289 120 : tree type;
4290 :
4291 120 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4292 120 : type = TREE_TYPE (args[0]);
4293 :
4294 120 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4295 120 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4296 120 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4297 :
4298 120 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4299 : rad2deg (expr->ts.kind));
4300 120 : }
4301 :
4302 :
4303 : /* COUNT(A) = Number of true elements in A. */
4304 : static void
4305 143 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4306 : {
4307 143 : tree resvar;
4308 143 : tree type;
4309 143 : stmtblock_t body;
4310 143 : tree tmp;
4311 143 : gfc_loopinfo loop;
4312 143 : gfc_actual_arglist *actual;
4313 143 : gfc_ss *arrayss;
4314 143 : gfc_se arrayse;
4315 :
4316 143 : if (se->ss)
4317 : {
4318 0 : gfc_conv_intrinsic_funcall (se, expr);
4319 0 : return;
4320 : }
4321 :
4322 143 : actual = expr->value.function.actual;
4323 :
4324 143 : type = gfc_typenode_for_spec (&expr->ts);
4325 : /* Initialize the result. */
4326 143 : resvar = gfc_create_var (type, "count");
4327 143 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4328 :
4329 : /* Walk the arguments. */
4330 143 : arrayss = gfc_walk_expr (actual->expr);
4331 143 : gcc_assert (arrayss != gfc_ss_terminator);
4332 :
4333 : /* Initialize the scalarizer. */
4334 143 : gfc_init_loopinfo (&loop);
4335 143 : gfc_add_ss_to_loop (&loop, arrayss);
4336 :
4337 : /* Initialize the loop. */
4338 143 : gfc_conv_ss_startstride (&loop);
4339 143 : gfc_conv_loop_setup (&loop, &expr->where);
4340 :
4341 143 : gfc_mark_ss_chain_used (arrayss, 1);
4342 : /* Generate the loop body. */
4343 143 : gfc_start_scalarized_body (&loop, &body);
4344 :
4345 143 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4346 143 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4347 143 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4348 :
4349 143 : gfc_init_se (&arrayse, NULL);
4350 143 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4351 143 : arrayse.ss = arrayss;
4352 143 : gfc_conv_expr_val (&arrayse, actual->expr);
4353 143 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4354 : build_empty_stmt (input_location));
4355 :
4356 143 : gfc_add_block_to_block (&body, &arrayse.pre);
4357 143 : gfc_add_expr_to_block (&body, tmp);
4358 143 : gfc_add_block_to_block (&body, &arrayse.post);
4359 :
4360 143 : gfc_trans_scalarizing_loops (&loop, &body);
4361 :
4362 143 : gfc_add_block_to_block (&se->pre, &loop.pre);
4363 143 : gfc_add_block_to_block (&se->pre, &loop.post);
4364 143 : gfc_cleanup_loop (&loop);
4365 :
4366 143 : se->expr = resvar;
4367 : }
4368 :
4369 :
4370 : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4371 : struct and return the corresponding loopinfo. */
4372 :
4373 : static gfc_loopinfo *
4374 3374 : enter_nested_loop (gfc_se *se)
4375 : {
4376 3374 : se->ss = se->ss->nested_ss;
4377 3374 : gcc_assert (se->ss == se->ss->loop->ss);
4378 :
4379 3374 : return se->ss->loop;
4380 : }
4381 :
4382 : /* Build the condition for a mask, which may be optional. */
4383 :
4384 : static tree
4385 12763 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4386 : bool optional_mask)
4387 : {
4388 12763 : tree present;
4389 12763 : tree type;
4390 :
4391 12763 : if (optional_mask)
4392 : {
4393 206 : type = TREE_TYPE (maskse->expr);
4394 206 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4395 206 : present = convert (type, present);
4396 206 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4397 : present);
4398 206 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4399 206 : type, present, maskse->expr);
4400 : }
4401 : else
4402 12557 : return maskse->expr;
4403 : }
4404 :
4405 : /* Inline implementation of the sum and product intrinsics. */
4406 : static void
4407 2515 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4408 : bool norm2)
4409 : {
4410 2515 : tree resvar;
4411 2515 : tree scale = NULL_TREE;
4412 2515 : tree type;
4413 2515 : stmtblock_t body;
4414 2515 : stmtblock_t block;
4415 2515 : tree tmp;
4416 2515 : gfc_loopinfo loop, *ploop;
4417 2515 : gfc_actual_arglist *arg_array, *arg_mask;
4418 2515 : gfc_ss *arrayss = NULL;
4419 2515 : gfc_ss *maskss = NULL;
4420 2515 : gfc_se arrayse;
4421 2515 : gfc_se maskse;
4422 2515 : gfc_se *parent_se;
4423 2515 : gfc_expr *arrayexpr;
4424 2515 : gfc_expr *maskexpr;
4425 2515 : bool optional_mask;
4426 :
4427 2515 : if (expr->rank > 0)
4428 : {
4429 578 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4430 : parent_se = se;
4431 : }
4432 : else
4433 : parent_se = NULL;
4434 :
4435 2515 : type = gfc_typenode_for_spec (&expr->ts);
4436 : /* Initialize the result. */
4437 2515 : resvar = gfc_create_var (type, "val");
4438 2515 : if (norm2)
4439 : {
4440 : /* result = 0.0;
4441 : scale = 1.0. */
4442 68 : scale = gfc_create_var (type, "scale");
4443 68 : gfc_add_modify (&se->pre, scale,
4444 : gfc_build_const (type, integer_one_node));
4445 68 : tmp = gfc_build_const (type, integer_zero_node);
4446 : }
4447 2447 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4448 2029 : tmp = gfc_build_const (type, integer_zero_node);
4449 418 : else if (op == NE_EXPR)
4450 : /* PARITY. */
4451 36 : tmp = convert (type, boolean_false_node);
4452 382 : else if (op == BIT_AND_EXPR)
4453 24 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4454 : type, integer_one_node));
4455 : else
4456 358 : tmp = gfc_build_const (type, integer_one_node);
4457 :
4458 2515 : gfc_add_modify (&se->pre, resvar, tmp);
4459 :
4460 2515 : arg_array = expr->value.function.actual;
4461 :
4462 2515 : arrayexpr = arg_array->expr;
4463 :
4464 2515 : if (op == NE_EXPR || norm2)
4465 : {
4466 : /* PARITY and NORM2. */
4467 : maskexpr = NULL;
4468 : optional_mask = false;
4469 : }
4470 : else
4471 : {
4472 2411 : arg_mask = arg_array->next->next;
4473 2411 : gcc_assert (arg_mask != NULL);
4474 2411 : maskexpr = arg_mask->expr;
4475 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4476 266 : && maskexpr->symtree->n.sym->attr.dummy
4477 2429 : && maskexpr->symtree->n.sym->attr.optional;
4478 : }
4479 :
4480 2515 : if (expr->rank == 0)
4481 : {
4482 : /* Walk the arguments. */
4483 1937 : arrayss = gfc_walk_expr (arrayexpr);
4484 1937 : gcc_assert (arrayss != gfc_ss_terminator);
4485 :
4486 1937 : if (maskexpr && maskexpr->rank > 0)
4487 : {
4488 223 : maskss = gfc_walk_expr (maskexpr);
4489 223 : gcc_assert (maskss != gfc_ss_terminator);
4490 : }
4491 : else
4492 : maskss = NULL;
4493 :
4494 : /* Initialize the scalarizer. */
4495 1937 : gfc_init_loopinfo (&loop);
4496 :
4497 : /* We add the mask first because the number of iterations is
4498 : taken from the last ss, and this breaks if an absent
4499 : optional argument is used for mask. */
4500 :
4501 1937 : if (maskexpr && maskexpr->rank > 0)
4502 223 : gfc_add_ss_to_loop (&loop, maskss);
4503 1937 : gfc_add_ss_to_loop (&loop, arrayss);
4504 :
4505 : /* Initialize the loop. */
4506 1937 : gfc_conv_ss_startstride (&loop);
4507 1937 : gfc_conv_loop_setup (&loop, &expr->where);
4508 :
4509 1937 : if (maskexpr && maskexpr->rank > 0)
4510 223 : gfc_mark_ss_chain_used (maskss, 1);
4511 1937 : gfc_mark_ss_chain_used (arrayss, 1);
4512 :
4513 1937 : ploop = &loop;
4514 : }
4515 : else
4516 : /* All the work has been done in the parent loops. */
4517 578 : ploop = enter_nested_loop (se);
4518 :
4519 2515 : gcc_assert (ploop);
4520 :
4521 : /* Generate the loop body. */
4522 2515 : gfc_start_scalarized_body (ploop, &body);
4523 :
4524 : /* If we have a mask, only add this element if the mask is set. */
4525 2515 : if (maskexpr && maskexpr->rank > 0)
4526 : {
4527 307 : gfc_init_se (&maskse, parent_se);
4528 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4529 307 : if (expr->rank == 0)
4530 223 : maskse.ss = maskss;
4531 307 : gfc_conv_expr_val (&maskse, maskexpr);
4532 307 : gfc_add_block_to_block (&body, &maskse.pre);
4533 :
4534 307 : gfc_start_block (&block);
4535 : }
4536 : else
4537 2208 : gfc_init_block (&block);
4538 :
4539 : /* Do the actual summation/product. */
4540 2515 : gfc_init_se (&arrayse, parent_se);
4541 2515 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4542 2515 : if (expr->rank == 0)
4543 1937 : arrayse.ss = arrayss;
4544 2515 : gfc_conv_expr_val (&arrayse, arrayexpr);
4545 2515 : gfc_add_block_to_block (&block, &arrayse.pre);
4546 :
4547 2515 : if (norm2)
4548 : {
4549 : /* if (x (i) != 0.0)
4550 : {
4551 : absX = abs(x(i))
4552 : if (absX > scale)
4553 : {
4554 : val = scale/absX;
4555 : result = 1.0 + result * val * val;
4556 : scale = absX;
4557 : }
4558 : else
4559 : {
4560 : val = absX/scale;
4561 : result += val * val;
4562 : }
4563 : } */
4564 68 : tree res1, res2, cond, absX, val;
4565 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4566 :
4567 68 : gfc_init_block (&ifblock1);
4568 :
4569 68 : absX = gfc_create_var (type, "absX");
4570 68 : gfc_add_modify (&ifblock1, absX,
4571 : fold_build1_loc (input_location, ABS_EXPR, type,
4572 : arrayse.expr));
4573 68 : val = gfc_create_var (type, "val");
4574 68 : gfc_add_expr_to_block (&ifblock1, val);
4575 :
4576 68 : gfc_init_block (&ifblock2);
4577 68 : gfc_add_modify (&ifblock2, val,
4578 : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4579 : absX));
4580 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4581 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4582 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4583 : gfc_build_const (type, integer_one_node));
4584 68 : gfc_add_modify (&ifblock2, resvar, res1);
4585 68 : gfc_add_modify (&ifblock2, scale, absX);
4586 68 : res1 = gfc_finish_block (&ifblock2);
4587 :
4588 68 : gfc_init_block (&ifblock3);
4589 68 : gfc_add_modify (&ifblock3, val,
4590 : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4591 : scale));
4592 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4593 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4594 68 : gfc_add_modify (&ifblock3, resvar, res2);
4595 68 : res2 = gfc_finish_block (&ifblock3);
4596 :
4597 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4598 : absX, scale);
4599 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
4600 68 : gfc_add_expr_to_block (&ifblock1, tmp);
4601 68 : tmp = gfc_finish_block (&ifblock1);
4602 :
4603 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4604 : arrayse.expr,
4605 : gfc_build_const (type, integer_zero_node));
4606 :
4607 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4608 68 : gfc_add_expr_to_block (&block, tmp);
4609 : }
4610 : else
4611 : {
4612 2447 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4613 2447 : gfc_add_modify (&block, resvar, tmp);
4614 : }
4615 :
4616 2515 : gfc_add_block_to_block (&block, &arrayse.post);
4617 :
4618 2515 : if (maskexpr && maskexpr->rank > 0)
4619 : {
4620 : /* We enclose the above in if (mask) {...} . If the mask is an
4621 : optional argument, generate
4622 : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4623 307 : tree ifmask;
4624 307 : tmp = gfc_finish_block (&block);
4625 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4626 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4627 : build_empty_stmt (input_location));
4628 307 : }
4629 : else
4630 2208 : tmp = gfc_finish_block (&block);
4631 2515 : gfc_add_expr_to_block (&body, tmp);
4632 :
4633 2515 : gfc_trans_scalarizing_loops (ploop, &body);
4634 :
4635 : /* For a scalar mask, enclose the loop in an if statement. */
4636 2515 : if (maskexpr && maskexpr->rank == 0)
4637 : {
4638 64 : gfc_init_block (&block);
4639 64 : gfc_add_block_to_block (&block, &ploop->pre);
4640 64 : gfc_add_block_to_block (&block, &ploop->post);
4641 64 : tmp = gfc_finish_block (&block);
4642 :
4643 64 : if (expr->rank > 0)
4644 : {
4645 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4646 : build_empty_stmt (input_location));
4647 34 : gfc_advance_se_ss_chain (se);
4648 : }
4649 : else
4650 : {
4651 30 : tree ifmask;
4652 :
4653 30 : gcc_assert (expr->rank == 0);
4654 30 : gfc_init_se (&maskse, NULL);
4655 30 : gfc_conv_expr_val (&maskse, maskexpr);
4656 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4657 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4658 : build_empty_stmt (input_location));
4659 : }
4660 :
4661 64 : gfc_add_expr_to_block (&block, tmp);
4662 64 : gfc_add_block_to_block (&se->pre, &block);
4663 64 : gcc_assert (se->post.head == NULL);
4664 : }
4665 : else
4666 : {
4667 2451 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4668 2451 : gfc_add_block_to_block (&se->pre, &ploop->post);
4669 : }
4670 :
4671 2515 : if (expr->rank == 0)
4672 1937 : gfc_cleanup_loop (ploop);
4673 :
4674 2515 : if (norm2)
4675 : {
4676 : /* result = scale * sqrt(result). */
4677 68 : tree sqrt;
4678 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4679 68 : resvar = build_call_expr_loc (input_location,
4680 : sqrt, 1, resvar);
4681 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4682 : }
4683 :
4684 2515 : se->expr = resvar;
4685 2515 : }
4686 :
4687 :
4688 : /* Inline implementation of the dot_product intrinsic. This function
4689 : is based on gfc_conv_intrinsic_arith (the previous function). */
4690 : static void
4691 113 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4692 : {
4693 113 : tree resvar;
4694 113 : tree type;
4695 113 : stmtblock_t body;
4696 113 : stmtblock_t block;
4697 113 : tree tmp;
4698 113 : gfc_loopinfo loop;
4699 113 : gfc_actual_arglist *actual;
4700 113 : gfc_ss *arrayss1, *arrayss2;
4701 113 : gfc_se arrayse1, arrayse2;
4702 113 : gfc_expr *arrayexpr1, *arrayexpr2;
4703 :
4704 113 : type = gfc_typenode_for_spec (&expr->ts);
4705 :
4706 : /* Initialize the result. */
4707 113 : resvar = gfc_create_var (type, "val");
4708 113 : if (expr->ts.type == BT_LOGICAL)
4709 30 : tmp = build_int_cst (type, 0);
4710 : else
4711 83 : tmp = gfc_build_const (type, integer_zero_node);
4712 :
4713 113 : gfc_add_modify (&se->pre, resvar, tmp);
4714 :
4715 : /* Walk argument #1. */
4716 113 : actual = expr->value.function.actual;
4717 113 : arrayexpr1 = actual->expr;
4718 113 : arrayss1 = gfc_walk_expr (arrayexpr1);
4719 113 : gcc_assert (arrayss1 != gfc_ss_terminator);
4720 :
4721 : /* Walk argument #2. */
4722 113 : actual = actual->next;
4723 113 : arrayexpr2 = actual->expr;
4724 113 : arrayss2 = gfc_walk_expr (arrayexpr2);
4725 113 : gcc_assert (arrayss2 != gfc_ss_terminator);
4726 :
4727 : /* Initialize the scalarizer. */
4728 113 : gfc_init_loopinfo (&loop);
4729 113 : gfc_add_ss_to_loop (&loop, arrayss1);
4730 113 : gfc_add_ss_to_loop (&loop, arrayss2);
4731 :
4732 : /* Initialize the loop. */
4733 113 : gfc_conv_ss_startstride (&loop);
4734 113 : gfc_conv_loop_setup (&loop, &expr->where);
4735 :
4736 113 : gfc_mark_ss_chain_used (arrayss1, 1);
4737 113 : gfc_mark_ss_chain_used (arrayss2, 1);
4738 :
4739 : /* Generate the loop body. */
4740 113 : gfc_start_scalarized_body (&loop, &body);
4741 113 : gfc_init_block (&block);
4742 :
4743 : /* Make the tree expression for [conjg(]array1[)]. */
4744 113 : gfc_init_se (&arrayse1, NULL);
4745 113 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4746 113 : arrayse1.ss = arrayss1;
4747 113 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
4748 113 : if (expr->ts.type == BT_COMPLEX)
4749 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4750 : arrayse1.expr);
4751 113 : gfc_add_block_to_block (&block, &arrayse1.pre);
4752 :
4753 : /* Make the tree expression for array2. */
4754 113 : gfc_init_se (&arrayse2, NULL);
4755 113 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4756 113 : arrayse2.ss = arrayss2;
4757 113 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
4758 113 : gfc_add_block_to_block (&block, &arrayse2.pre);
4759 :
4760 : /* Do the actual product and sum. */
4761 113 : if (expr->ts.type == BT_LOGICAL)
4762 : {
4763 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4764 : arrayse1.expr, arrayse2.expr);
4765 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4766 : }
4767 : else
4768 : {
4769 83 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4770 : arrayse2.expr);
4771 83 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4772 : }
4773 113 : gfc_add_modify (&block, resvar, tmp);
4774 :
4775 : /* Finish up the loop block and the loop. */
4776 113 : tmp = gfc_finish_block (&block);
4777 113 : gfc_add_expr_to_block (&body, tmp);
4778 :
4779 113 : gfc_trans_scalarizing_loops (&loop, &body);
4780 113 : gfc_add_block_to_block (&se->pre, &loop.pre);
4781 113 : gfc_add_block_to_block (&se->pre, &loop.post);
4782 113 : gfc_cleanup_loop (&loop);
4783 :
4784 113 : se->expr = resvar;
4785 113 : }
4786 :
4787 :
4788 : /* Tells whether the expression E is a reference to an optional variable whose
4789 : presence is not known at compile time. Those are variable references without
4790 : subreference; if there is a subreference, we can assume the variable is
4791 : present. We have to special case full arrays, which we represent with a fake
4792 : "full" reference, and class descriptors for which a reference to data is not
4793 : really a subreference. */
4794 :
4795 : bool
4796 14613 : maybe_absent_optional_variable (gfc_expr *e)
4797 : {
4798 14613 : if (!(e && e->expr_type == EXPR_VARIABLE))
4799 : return false;
4800 :
4801 1716 : gfc_symbol *sym = e->symtree->n.sym;
4802 1716 : if (!sym->attr.optional)
4803 : return false;
4804 :
4805 224 : gfc_ref *ref = e->ref;
4806 224 : if (ref == nullptr)
4807 : return true;
4808 :
4809 20 : if (ref->type == REF_ARRAY
4810 20 : && ref->u.ar.type == AR_FULL
4811 20 : && ref->next == nullptr)
4812 : return true;
4813 :
4814 0 : if (!(sym->ts.type == BT_CLASS
4815 0 : && ref->type == REF_COMPONENT
4816 0 : && ref->u.c.component == CLASS_DATA (sym)))
4817 : return false;
4818 :
4819 0 : gfc_ref *next_ref = ref->next;
4820 0 : if (next_ref == nullptr)
4821 : return true;
4822 :
4823 0 : if (next_ref->type == REF_ARRAY
4824 0 : && next_ref->u.ar.type == AR_FULL
4825 0 : && next_ref->next == nullptr)
4826 0 : return true;
4827 :
4828 : return false;
4829 : }
4830 :
4831 :
4832 : /* Emit code for minloc or maxloc intrinsic. There are many different cases
4833 : we need to handle. For performance reasons we sometimes create two
4834 : loops instead of one, where the second one is much simpler.
4835 : Examples for minloc intrinsic:
4836 : A: Result is scalar.
4837 : 1) Array mask is used and NaNs need to be supported:
4838 : limit = Infinity;
4839 : pos = 0;
4840 : S = from;
4841 : while (S <= to) {
4842 : if (mask[S]) {
4843 : if (pos == 0) pos = S + (1 - from);
4844 : if (a[S] <= limit) {
4845 : limit = a[S];
4846 : pos = S + (1 - from);
4847 : goto lab1;
4848 : }
4849 : }
4850 : S++;
4851 : }
4852 : goto lab2;
4853 : lab1:;
4854 : while (S <= to) {
4855 : if (mask[S])
4856 : if (a[S] < limit) {
4857 : limit = a[S];
4858 : pos = S + (1 - from);
4859 : }
4860 : S++;
4861 : }
4862 : lab2:;
4863 : 2) NaNs need to be supported, but it is known at compile time or cheaply
4864 : at runtime whether array is nonempty or not:
4865 : limit = Infinity;
4866 : pos = 0;
4867 : S = from;
4868 : while (S <= to) {
4869 : if (a[S] <= limit) {
4870 : limit = a[S];
4871 : pos = S + (1 - from);
4872 : goto lab1;
4873 : }
4874 : S++;
4875 : }
4876 : if (from <= to) pos = 1;
4877 : goto lab2;
4878 : lab1:;
4879 : while (S <= to) {
4880 : if (a[S] < limit) {
4881 : limit = a[S];
4882 : pos = S + (1 - from);
4883 : }
4884 : S++;
4885 : }
4886 : lab2:;
4887 : 3) NaNs aren't supported, array mask is used:
4888 : limit = infinities_supported ? Infinity : huge (limit);
4889 : pos = 0;
4890 : S = from;
4891 : while (S <= to) {
4892 : if (mask[S]) {
4893 : limit = a[S];
4894 : pos = S + (1 - from);
4895 : goto lab1;
4896 : }
4897 : S++;
4898 : }
4899 : goto lab2;
4900 : lab1:;
4901 : while (S <= to) {
4902 : if (mask[S])
4903 : if (a[S] < limit) {
4904 : limit = a[S];
4905 : pos = S + (1 - from);
4906 : }
4907 : S++;
4908 : }
4909 : lab2:;
4910 : 4) Same without array mask:
4911 : limit = infinities_supported ? Infinity : huge (limit);
4912 : pos = (from <= to) ? 1 : 0;
4913 : S = from;
4914 : while (S <= to) {
4915 : if (a[S] < limit) {
4916 : limit = a[S];
4917 : pos = S + (1 - from);
4918 : }
4919 : S++;
4920 : }
4921 : B: Array result, non-CHARACTER type, DIM absent
4922 : Generate similar code as in the scalar case, using a collection of
4923 : variables (one per dimension) instead of a single variable as result.
4924 : Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4925 : becomes:
4926 : 1) Array mask is used and NaNs need to be supported:
4927 : limit = Infinity;
4928 : pos0 = 0;
4929 : pos1 = 0;
4930 : S1 = from1;
4931 : second_loop_entry = false;
4932 : while (S1 <= to1) {
4933 : S0 = from0;
4934 : while (s0 <= to0 {
4935 : if (mask[S1][S0]) {
4936 : if (pos0 == 0) {
4937 : pos0 = S0 + (1 - from0);
4938 : pos1 = S1 + (1 - from1);
4939 : }
4940 : if (a[S1][S0] <= limit) {
4941 : limit = a[S1][S0];
4942 : pos0 = S0 + (1 - from0);
4943 : pos1 = S1 + (1 - from1);
4944 : second_loop_entry = true;
4945 : goto lab1;
4946 : }
4947 : }
4948 : S0++;
4949 : }
4950 : S1++;
4951 : }
4952 : goto lab2;
4953 : lab1:;
4954 : S1 = second_loop_entry ? S1 : from1;
4955 : while (S1 <= to1) {
4956 : S0 = second_loop_entry ? S0 : from0;
4957 : while (S0 <= to0) {
4958 : if (mask[S1][S0])
4959 : if (a[S1][S0] < limit) {
4960 : limit = a[S1][S0];
4961 : pos0 = S + (1 - from0);
4962 : pos1 = S + (1 - from1);
4963 : }
4964 : second_loop_entry = false;
4965 : S0++;
4966 : }
4967 : S1++;
4968 : }
4969 : lab2:;
4970 : result = { pos0, pos1 };
4971 : ...
4972 : 4) NANs aren't supported, no array mask.
4973 : limit = infinities_supported ? Infinity : huge (limit);
4974 : pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4975 : pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4976 : S1 = from1;
4977 : while (S1 <= to1) {
4978 : S0 = from0;
4979 : while (S0 <= to0) {
4980 : if (a[S1][S0] < limit) {
4981 : limit = a[S1][S0];
4982 : pos0 = S + (1 - from0);
4983 : pos1 = S + (1 - from1);
4984 : }
4985 : S0++;
4986 : }
4987 : S1++;
4988 : }
4989 : result = { pos0, pos1 };
4990 : C: Otherwise, a call is generated.
4991 : For 2) and 4), if mask is scalar, this all goes into a conditional,
4992 : setting pos = 0; in the else branch.
4993 :
4994 : Since we now also support the BACK argument, instead of using
4995 : if (a[S] < limit), we now use
4996 :
4997 : if (back)
4998 : cond = a[S] <= limit;
4999 : else
5000 : cond = a[S] < limit;
5001 : if (cond) {
5002 : ....
5003 :
5004 : The optimizer is smart enough to move the condition out of the loop.
5005 : They are now marked as unlikely too for further speedup. */
5006 :
5007 : static void
5008 18898 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5009 : {
5010 18898 : stmtblock_t body;
5011 18898 : stmtblock_t block;
5012 18898 : stmtblock_t ifblock;
5013 18898 : stmtblock_t elseblock;
5014 18898 : tree limit;
5015 18898 : tree type;
5016 18898 : tree tmp;
5017 18898 : tree cond;
5018 18898 : tree elsetmp;
5019 18898 : tree ifbody;
5020 18898 : tree offset[GFC_MAX_DIMENSIONS];
5021 18898 : tree nonempty;
5022 18898 : tree lab1, lab2;
5023 18898 : tree b_if, b_else;
5024 18898 : tree back;
5025 18898 : gfc_loopinfo loop, *ploop;
5026 18898 : gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5027 18898 : gfc_actual_arglist *back_arg;
5028 18898 : gfc_ss *arrayss = nullptr;
5029 18898 : gfc_ss *maskss = nullptr;
5030 18898 : gfc_ss *orig_ss = nullptr;
5031 18898 : gfc_se arrayse;
5032 18898 : gfc_se maskse;
5033 18898 : gfc_se nested_se;
5034 18898 : gfc_se *base_se;
5035 18898 : gfc_expr *arrayexpr;
5036 18898 : gfc_expr *maskexpr;
5037 18898 : gfc_expr *backexpr;
5038 18898 : gfc_se backse;
5039 18898 : tree pos[GFC_MAX_DIMENSIONS];
5040 18898 : tree idx[GFC_MAX_DIMENSIONS];
5041 18898 : tree result_var = NULL_TREE;
5042 18898 : int n;
5043 18898 : bool optional_mask;
5044 :
5045 18898 : array_arg = expr->value.function.actual;
5046 18898 : dim_arg = array_arg->next;
5047 18898 : mask_arg = dim_arg->next;
5048 18898 : kind_arg = mask_arg->next;
5049 18898 : back_arg = kind_arg->next;
5050 :
5051 18898 : bool dim_present = dim_arg->expr != nullptr;
5052 18898 : bool nested_loop = dim_present && expr->rank > 0;
5053 :
5054 : /* Remove kind. */
5055 18898 : if (kind_arg->expr)
5056 : {
5057 2240 : gfc_free_expr (kind_arg->expr);
5058 2240 : kind_arg->expr = NULL;
5059 : }
5060 :
5061 : /* Pass BACK argument by value. */
5062 18898 : back_arg->name = "%VAL";
5063 :
5064 18898 : if (se->ss)
5065 : {
5066 14732 : if (se->ss->info->useflags)
5067 : {
5068 7671 : if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5069 : {
5070 : /* The code generating and initializing the result array has been
5071 : generated already before the scalarization loop, either with a
5072 : library function call or with inline code; now we can just use
5073 : the result. */
5074 4875 : gfc_conv_tmp_array_ref (se);
5075 13822 : return;
5076 : }
5077 : }
5078 7061 : else if (!gfc_inline_intrinsic_function_p (expr))
5079 : {
5080 3780 : gfc_conv_intrinsic_funcall (se, expr);
5081 3780 : return;
5082 : }
5083 : }
5084 :
5085 10243 : arrayexpr = array_arg->expr;
5086 :
5087 : /* Special case for character maxloc. Remove unneeded "dim" actual
5088 : argument, then call a library function. */
5089 :
5090 10243 : if (arrayexpr->ts.type == BT_CHARACTER)
5091 : {
5092 292 : gcc_assert (expr->rank == 0);
5093 :
5094 292 : if (dim_arg->expr)
5095 : {
5096 292 : gfc_free_expr (dim_arg->expr);
5097 292 : dim_arg->expr = NULL;
5098 : }
5099 292 : gfc_conv_intrinsic_funcall (se, expr);
5100 292 : return;
5101 : }
5102 :
5103 9951 : type = gfc_typenode_for_spec (&expr->ts);
5104 :
5105 9951 : if (expr->rank > 0 && !dim_present)
5106 : {
5107 3281 : gfc_array_spec as;
5108 3281 : memset (&as, 0, sizeof (as));
5109 :
5110 3281 : as.rank = 1;
5111 3281 : as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5112 : &arrayexpr->where,
5113 : HOST_WIDE_INT_1);
5114 6562 : as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5115 : &arrayexpr->where,
5116 3281 : arrayexpr->rank);
5117 :
5118 3281 : tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5119 :
5120 3281 : result_var = gfc_create_var (array, "loc_result");
5121 : }
5122 :
5123 7155 : const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5124 :
5125 : /* Initialize the result. */
5126 22177 : for (int i = 0; i < reduction_dimensions; i++)
5127 : {
5128 12226 : pos[i] = gfc_create_var (gfc_array_index_type,
5129 : gfc_get_string ("pos%d", i));
5130 12226 : offset[i] = gfc_create_var (gfc_array_index_type,
5131 : gfc_get_string ("offset%d", i));
5132 12226 : idx[i] = gfc_create_var (gfc_array_index_type,
5133 : gfc_get_string ("idx%d", i));
5134 : }
5135 :
5136 9951 : maskexpr = mask_arg->expr;
5137 6518 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5138 5329 : && maskexpr->symtree->n.sym->attr.dummy
5139 10116 : && maskexpr->symtree->n.sym->attr.optional;
5140 9951 : backexpr = back_arg->expr;
5141 :
5142 17106 : gfc_init_se (&backse, nested_loop ? se : nullptr);
5143 9951 : if (backexpr == nullptr)
5144 0 : back = logical_false_node;
5145 9951 : else if (maybe_absent_optional_variable (backexpr))
5146 : {
5147 : /* This should have been checked already by
5148 : maybe_absent_optional_variable. */
5149 184 : gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5150 :
5151 184 : gfc_conv_expr (&backse, backexpr);
5152 184 : tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
5153 184 : back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5154 : logical_type_node, present, backse.expr);
5155 : }
5156 : else
5157 : {
5158 9767 : gfc_conv_expr (&backse, backexpr);
5159 9767 : back = backse.expr;
5160 : }
5161 9951 : gfc_add_block_to_block (&se->pre, &backse.pre);
5162 9951 : back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5163 9951 : gfc_add_block_to_block (&se->pre, &backse.post);
5164 :
5165 9951 : if (nested_loop)
5166 : {
5167 2796 : gfc_init_se (&nested_se, se);
5168 2796 : base_se = &nested_se;
5169 : }
5170 : else
5171 : {
5172 : /* Walk the arguments. */
5173 7155 : arrayss = gfc_walk_expr (arrayexpr);
5174 7155 : gcc_assert (arrayss != gfc_ss_terminator);
5175 :
5176 7155 : if (maskexpr && maskexpr->rank != 0)
5177 : {
5178 2700 : maskss = gfc_walk_expr (maskexpr);
5179 2700 : gcc_assert (maskss != gfc_ss_terminator);
5180 : }
5181 :
5182 : base_se = nullptr;
5183 : }
5184 :
5185 18091 : nonempty = nullptr;
5186 7448 : if (!(maskexpr && maskexpr->rank > 0))
5187 : {
5188 6077 : mpz_t asize;
5189 6077 : bool reduction_size_known;
5190 :
5191 6077 : if (dim_present)
5192 : {
5193 4032 : int reduction_dim;
5194 4032 : if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5195 4030 : reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5196 2 : else if (arrayexpr->rank == 1)
5197 : reduction_dim = 0;
5198 : else
5199 0 : gcc_unreachable ();
5200 4032 : reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5201 : &asize);
5202 : }
5203 : else
5204 2045 : reduction_size_known = gfc_array_size (arrayexpr, &asize);
5205 :
5206 6077 : if (reduction_size_known)
5207 : {
5208 4482 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5209 4482 : mpz_clear (asize);
5210 4482 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5211 : logical_type_node, nonempty,
5212 : gfc_index_zero_node);
5213 : }
5214 6077 : maskss = NULL;
5215 : }
5216 :
5217 9951 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5218 9951 : switch (arrayexpr->ts.type)
5219 : {
5220 3898 : case BT_REAL:
5221 3898 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5222 3898 : break;
5223 :
5224 6029 : case BT_INTEGER:
5225 6029 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5226 6029 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5227 : arrayexpr->ts.kind);
5228 6029 : break;
5229 :
5230 24 : case BT_UNSIGNED:
5231 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5232 24 : if (op == GT_EXPR)
5233 : {
5234 12 : tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5235 12 : tmp = build_int_cst (tmp, 0);
5236 : }
5237 : else
5238 : {
5239 12 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5240 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5241 : expr->ts.kind);
5242 : }
5243 : break;
5244 :
5245 0 : default:
5246 0 : gcc_unreachable ();
5247 : }
5248 :
5249 : /* We start with the most negative possible value for MAXLOC, and the most
5250 : positive possible value for MINLOC. The most negative possible value is
5251 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5252 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5253 : with above. */
5254 9951 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5255 4724 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5256 4724 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5257 2914 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5258 2914 : build_int_cst (TREE_TYPE (tmp), 1));
5259 :
5260 9951 : gfc_add_modify (&se->pre, limit, tmp);
5261 :
5262 : /* If we are in a case where we generate two sets of loops, the second one
5263 : should continue where the first stopped instead of restarting from the
5264 : beginning. So nested loops in the second set should have a partial range
5265 : on the first iteration, but they should start from the beginning and span
5266 : their full range on the following iterations. So we use conditionals in
5267 : the loops lower bounds, and use the following variable in those
5268 : conditionals to decide whether to use the original loop bound or to use
5269 : the index at which the loop from the first set stopped. */
5270 9951 : tree second_loop_entry = gfc_create_var (logical_type_node,
5271 : "second_loop_entry");
5272 9951 : gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5273 :
5274 9951 : if (nested_loop)
5275 : {
5276 2796 : ploop = enter_nested_loop (&nested_se);
5277 2796 : orig_ss = nested_se.ss;
5278 2796 : ploop->temp_dim = 1;
5279 : }
5280 : else
5281 : {
5282 : /* Initialize the scalarizer. */
5283 7155 : gfc_init_loopinfo (&loop);
5284 :
5285 : /* We add the mask first because the number of iterations is taken
5286 : from the last ss, and this breaks if an absent optional argument
5287 : is used for mask. */
5288 :
5289 7155 : if (maskss)
5290 2700 : gfc_add_ss_to_loop (&loop, maskss);
5291 :
5292 7155 : gfc_add_ss_to_loop (&loop, arrayss);
5293 :
5294 : /* Initialize the loop. */
5295 7155 : gfc_conv_ss_startstride (&loop);
5296 :
5297 : /* The code generated can have more than one loop in sequence (see the
5298 : comment at the function header). This doesn't work well with the
5299 : scalarizer, which changes arrays' offset when the scalarization loops
5300 : are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5301 : the scalarizer temporary code to handle multiple loops. Thus, we set
5302 : temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5303 : we use gfc_trans_scalarized_loop_boundary even later to restore
5304 : offset. */
5305 7155 : loop.temp_dim = loop.dimen;
5306 7155 : gfc_conv_loop_setup (&loop, &expr->where);
5307 :
5308 7155 : ploop = &loop;
5309 : }
5310 :
5311 9951 : gcc_assert (reduction_dimensions == ploop->dimen);
5312 :
5313 9951 : if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5314 : {
5315 1595 : nonempty = logical_true_node;
5316 :
5317 3697 : for (int i = 0; i < ploop->dimen; i++)
5318 : {
5319 2102 : if (!(ploop->from[i] && ploop->to[i]))
5320 : {
5321 : nonempty = NULL;
5322 : break;
5323 : }
5324 :
5325 2102 : tree tmp = fold_build2_loc (input_location, LE_EXPR,
5326 : logical_type_node, ploop->from[i],
5327 : ploop->to[i]);
5328 :
5329 2102 : nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5330 : logical_type_node, nonempty, tmp);
5331 : }
5332 : }
5333 :
5334 11546 : lab1 = NULL;
5335 11546 : lab2 = NULL;
5336 : /* Initialize the position to zero, following Fortran 2003. We are free
5337 : to do this because Fortran 95 allows the result of an entirely false
5338 : mask to be processor dependent. If we know at compile time the array
5339 : is non-empty and no MASK is used, we can initialize to 1 to simplify
5340 : the inner loop. */
5341 9951 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5342 : {
5343 3748 : tree init = fold_build3_loc (input_location, COND_EXPR,
5344 : gfc_array_index_type, nonempty,
5345 : gfc_index_one_node,
5346 : gfc_index_zero_node);
5347 8430 : for (int i = 0; i < ploop->dimen; i++)
5348 4682 : gfc_add_modify (&ploop->pre, pos[i], init);
5349 : }
5350 : else
5351 : {
5352 13747 : for (int i = 0; i < ploop->dimen; i++)
5353 7544 : gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5354 6203 : lab1 = gfc_build_label_decl (NULL_TREE);
5355 6203 : TREE_USED (lab1) = 1;
5356 6203 : lab2 = gfc_build_label_decl (NULL_TREE);
5357 6203 : TREE_USED (lab2) = 1;
5358 : }
5359 :
5360 : /* An offset must be added to the loop
5361 : counter to obtain the required position. */
5362 22177 : for (int i = 0; i < ploop->dimen; i++)
5363 : {
5364 12226 : gcc_assert (ploop->from[i]);
5365 :
5366 12226 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5367 : gfc_index_one_node, ploop->from[i]);
5368 12226 : gfc_add_modify (&ploop->pre, offset[i], tmp);
5369 : }
5370 :
5371 9951 : if (!nested_loop)
5372 : {
5373 9965 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5374 7155 : if (maskss)
5375 2700 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5376 : }
5377 :
5378 : /* Generate the loop body. */
5379 9951 : gfc_start_scalarized_body (ploop, &body);
5380 :
5381 : /* If we have a mask, only check this element if the mask is set. */
5382 9951 : if (maskexpr && maskexpr->rank > 0)
5383 : {
5384 3874 : gfc_init_se (&maskse, base_se);
5385 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5386 3874 : if (!nested_loop)
5387 2700 : maskse.ss = maskss;
5388 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5389 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5390 :
5391 3874 : gfc_start_block (&block);
5392 : }
5393 : else
5394 6077 : gfc_init_block (&block);
5395 :
5396 : /* Compare with the current limit. */
5397 9951 : gfc_init_se (&arrayse, base_se);
5398 9951 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5399 9951 : if (!nested_loop)
5400 7155 : arrayse.ss = arrayss;
5401 9951 : gfc_conv_expr_val (&arrayse, arrayexpr);
5402 9951 : gfc_add_block_to_block (&block, &arrayse.pre);
5403 :
5404 : /* We do the following if this is a more extreme value. */
5405 9951 : gfc_start_block (&ifblock);
5406 :
5407 : /* Assign the value to the limit... */
5408 9951 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5409 :
5410 9951 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5411 : {
5412 1569 : stmtblock_t ifblock2;
5413 1569 : tree ifbody2;
5414 :
5415 1569 : gfc_start_block (&ifblock2);
5416 3439 : for (int i = 0; i < ploop->dimen; i++)
5417 : {
5418 1870 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5419 : ploop->loopvar[i], offset[i]);
5420 1870 : gfc_add_modify (&ifblock2, pos[i], tmp);
5421 : }
5422 1569 : ifbody2 = gfc_finish_block (&ifblock2);
5423 :
5424 1569 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5425 : pos[0], gfc_index_zero_node);
5426 1569 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5427 : build_empty_stmt (input_location));
5428 1569 : gfc_add_expr_to_block (&block, tmp);
5429 : }
5430 :
5431 22177 : for (int i = 0; i < ploop->dimen; i++)
5432 : {
5433 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5434 : ploop->loopvar[i], offset[i]);
5435 12226 : gfc_add_modify (&ifblock, pos[i], tmp);
5436 12226 : gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5437 : }
5438 :
5439 9951 : gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5440 :
5441 9951 : if (lab1)
5442 6203 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5443 :
5444 9951 : ifbody = gfc_finish_block (&ifblock);
5445 :
5446 9951 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5447 : {
5448 7646 : if (lab1)
5449 5998 : cond = fold_build2_loc (input_location,
5450 : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5451 : logical_type_node, arrayse.expr, limit);
5452 : else
5453 : {
5454 3748 : tree ifbody2, elsebody2;
5455 :
5456 : /* We switch to > or >= depending on the value of the BACK argument. */
5457 3748 : cond = gfc_create_var (logical_type_node, "cond");
5458 :
5459 3748 : gfc_start_block (&ifblock);
5460 5641 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5461 : logical_type_node, arrayse.expr, limit);
5462 :
5463 3748 : gfc_add_modify (&ifblock, cond, b_if);
5464 3748 : ifbody2 = gfc_finish_block (&ifblock);
5465 :
5466 3748 : gfc_start_block (&elseblock);
5467 3748 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5468 : arrayse.expr, limit);
5469 :
5470 3748 : gfc_add_modify (&elseblock, cond, b_else);
5471 3748 : elsebody2 = gfc_finish_block (&elseblock);
5472 :
5473 3748 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5474 : back, ifbody2, elsebody2);
5475 :
5476 3748 : gfc_add_expr_to_block (&block, tmp);
5477 : }
5478 :
5479 7646 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5480 7646 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5481 : build_empty_stmt (input_location));
5482 : }
5483 9951 : gfc_add_expr_to_block (&block, ifbody);
5484 :
5485 9951 : if (maskexpr && maskexpr->rank > 0)
5486 : {
5487 : /* We enclose the above in if (mask) {...}. If the mask is an
5488 : optional argument, generate IF (.NOT. PRESENT(MASK)
5489 : .OR. MASK(I)). */
5490 :
5491 3874 : tree ifmask;
5492 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5493 3874 : tmp = gfc_finish_block (&block);
5494 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5495 : build_empty_stmt (input_location));
5496 3874 : }
5497 : else
5498 6077 : tmp = gfc_finish_block (&block);
5499 9951 : gfc_add_expr_to_block (&body, tmp);
5500 :
5501 9951 : if (lab1)
5502 : {
5503 13747 : for (int i = 0; i < ploop->dimen; i++)
5504 7544 : ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5505 7544 : TREE_TYPE (ploop->from[i]),
5506 : second_loop_entry, idx[i],
5507 : ploop->from[i]);
5508 :
5509 6203 : gfc_trans_scalarized_loop_boundary (ploop, &body);
5510 :
5511 6203 : if (nested_loop)
5512 : {
5513 : /* The first loop already advanced the parent se'ss chain, so clear
5514 : the parent now to avoid doing it a second time, making the chain
5515 : out of sync. */
5516 1858 : nested_se.parent = nullptr;
5517 1858 : nested_se.ss = orig_ss;
5518 : }
5519 :
5520 6203 : stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5521 :
5522 6203 : if (HONOR_NANS (DECL_MODE (limit)))
5523 : {
5524 3898 : if (nonempty != NULL)
5525 : {
5526 2329 : stmtblock_t init_block;
5527 2329 : gfc_init_block (&init_block);
5528 :
5529 5229 : for (int i = 0; i < ploop->dimen; i++)
5530 2900 : gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5531 :
5532 2329 : tree ifbody = gfc_finish_block (&init_block);
5533 2329 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5534 : build_empty_stmt (input_location));
5535 2329 : gfc_add_expr_to_block (outer_block, tmp);
5536 : }
5537 : }
5538 :
5539 6203 : gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5540 6203 : gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5541 :
5542 : /* If we have a mask, only check this element if the mask is set. */
5543 6203 : if (maskexpr && maskexpr->rank > 0)
5544 : {
5545 3874 : gfc_init_se (&maskse, base_se);
5546 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5547 3874 : if (!nested_loop)
5548 2700 : maskse.ss = maskss;
5549 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5550 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5551 :
5552 3874 : gfc_start_block (&block);
5553 : }
5554 : else
5555 2329 : gfc_init_block (&block);
5556 :
5557 : /* Compare with the current limit. */
5558 6203 : gfc_init_se (&arrayse, base_se);
5559 6203 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5560 6203 : if (!nested_loop)
5561 4345 : arrayse.ss = arrayss;
5562 6203 : gfc_conv_expr_val (&arrayse, arrayexpr);
5563 6203 : gfc_add_block_to_block (&block, &arrayse.pre);
5564 :
5565 : /* We do the following if this is a more extreme value. */
5566 6203 : gfc_start_block (&ifblock);
5567 :
5568 : /* Assign the value to the limit... */
5569 6203 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5570 :
5571 13747 : for (int i = 0; i < ploop->dimen; i++)
5572 : {
5573 7544 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5574 : ploop->loopvar[i], offset[i]);
5575 7544 : gfc_add_modify (&ifblock, pos[i], tmp);
5576 : }
5577 :
5578 6203 : ifbody = gfc_finish_block (&ifblock);
5579 :
5580 : /* We switch to > or >= depending on the value of the BACK argument. */
5581 6203 : {
5582 6203 : tree ifbody2, elsebody2;
5583 :
5584 6203 : cond = gfc_create_var (logical_type_node, "cond");
5585 :
5586 6203 : gfc_start_block (&ifblock);
5587 9537 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5588 : logical_type_node, arrayse.expr, limit);
5589 :
5590 6203 : gfc_add_modify (&ifblock, cond, b_if);
5591 6203 : ifbody2 = gfc_finish_block (&ifblock);
5592 :
5593 6203 : gfc_start_block (&elseblock);
5594 6203 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5595 : arrayse.expr, limit);
5596 :
5597 6203 : gfc_add_modify (&elseblock, cond, b_else);
5598 6203 : elsebody2 = gfc_finish_block (&elseblock);
5599 :
5600 6203 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5601 : back, ifbody2, elsebody2);
5602 : }
5603 :
5604 6203 : gfc_add_expr_to_block (&block, tmp);
5605 6203 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5606 6203 : tmp = build3_v (COND_EXPR, cond, ifbody,
5607 : build_empty_stmt (input_location));
5608 :
5609 6203 : gfc_add_expr_to_block (&block, tmp);
5610 :
5611 6203 : if (maskexpr && maskexpr->rank > 0)
5612 : {
5613 : /* We enclose the above in if (mask) {...}. If the mask is
5614 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5615 : .OR. MASK(I)).*/
5616 :
5617 3874 : tree ifmask;
5618 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5619 3874 : tmp = gfc_finish_block (&block);
5620 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5621 : build_empty_stmt (input_location));
5622 3874 : }
5623 : else
5624 2329 : tmp = gfc_finish_block (&block);
5625 :
5626 6203 : gfc_add_expr_to_block (&body, tmp);
5627 6203 : gfc_add_modify (&body, second_loop_entry, logical_false_node);
5628 : }
5629 :
5630 9951 : gfc_trans_scalarizing_loops (ploop, &body);
5631 :
5632 9951 : if (lab2)
5633 6203 : gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5634 :
5635 : /* For a scalar mask, enclose the loop in an if statement. */
5636 9951 : if (maskexpr && maskexpr->rank == 0)
5637 : {
5638 2644 : tree ifmask;
5639 :
5640 2644 : gfc_init_se (&maskse, nested_loop ? se : nullptr);
5641 2644 : gfc_conv_expr_val (&maskse, maskexpr);
5642 2644 : gfc_add_block_to_block (&se->pre, &maskse.pre);
5643 2644 : gfc_init_block (&block);
5644 2644 : gfc_add_block_to_block (&block, &ploop->pre);
5645 2644 : gfc_add_block_to_block (&block, &ploop->post);
5646 2644 : tmp = gfc_finish_block (&block);
5647 :
5648 : /* For the else part of the scalar mask, just initialize
5649 : the pos variable the same way as above. */
5650 :
5651 2644 : gfc_init_block (&elseblock);
5652 5580 : for (int i = 0; i < ploop->dimen; i++)
5653 2936 : gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5654 2644 : elsetmp = gfc_finish_block (&elseblock);
5655 2644 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5656 2644 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5657 2644 : gfc_add_expr_to_block (&block, tmp);
5658 2644 : gfc_add_block_to_block (&se->pre, &block);
5659 2644 : }
5660 : else
5661 : {
5662 7307 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5663 7307 : gfc_add_block_to_block (&se->pre, &ploop->post);
5664 : }
5665 :
5666 9951 : if (!nested_loop)
5667 7155 : gfc_cleanup_loop (&loop);
5668 :
5669 9951 : if (!dim_present)
5670 : {
5671 8837 : for (int i = 0; i < arrayexpr->rank; i++)
5672 : {
5673 5556 : tree res_idx = build_int_cst (gfc_array_index_type, i);
5674 5556 : tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5675 : NULL_TREE, true);
5676 :
5677 5556 : tree value = convert (type, pos[i]);
5678 5556 : gfc_add_modify (&se->pre, res_arr_ref, value);
5679 : }
5680 :
5681 3281 : se->expr = result_var;
5682 : }
5683 : else
5684 6670 : se->expr = convert (type, pos[0]);
5685 : }
5686 :
5687 : /* Emit code for findloc. */
5688 :
5689 : static void
5690 1332 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5691 : {
5692 1332 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5693 : *kind_arg, *back_arg;
5694 1332 : gfc_expr *value_expr;
5695 1332 : int ikind;
5696 1332 : tree resvar;
5697 1332 : stmtblock_t block;
5698 1332 : stmtblock_t body;
5699 1332 : stmtblock_t loopblock;
5700 1332 : tree type;
5701 1332 : tree tmp;
5702 1332 : tree found;
5703 1332 : tree forward_branch = NULL_TREE;
5704 1332 : tree back_branch;
5705 1332 : gfc_loopinfo loop;
5706 1332 : gfc_ss *arrayss;
5707 1332 : gfc_ss *maskss;
5708 1332 : gfc_se arrayse;
5709 1332 : gfc_se valuese;
5710 1332 : gfc_se maskse;
5711 1332 : gfc_se backse;
5712 1332 : tree exit_label;
5713 1332 : gfc_expr *maskexpr;
5714 1332 : tree offset;
5715 1332 : int i;
5716 1332 : bool optional_mask;
5717 :
5718 1332 : array_arg = expr->value.function.actual;
5719 1332 : value_arg = array_arg->next;
5720 1332 : dim_arg = value_arg->next;
5721 1332 : mask_arg = dim_arg->next;
5722 1332 : kind_arg = mask_arg->next;
5723 1332 : back_arg = kind_arg->next;
5724 :
5725 : /* Remove kind and set ikind. */
5726 1332 : if (kind_arg->expr)
5727 : {
5728 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5729 0 : gfc_free_expr (kind_arg->expr);
5730 0 : kind_arg->expr = NULL;
5731 : }
5732 : else
5733 1332 : ikind = gfc_default_integer_kind;
5734 :
5735 1332 : value_expr = value_arg->expr;
5736 :
5737 : /* Unless it's a string, pass VALUE by value. */
5738 1332 : if (value_expr->ts.type != BT_CHARACTER)
5739 732 : value_arg->name = "%VAL";
5740 :
5741 : /* Pass BACK argument by value. */
5742 1332 : back_arg->name = "%VAL";
5743 :
5744 : /* Call the library if we have a character function or if
5745 : rank > 0. */
5746 1332 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5747 : {
5748 1200 : se->ignore_optional = 1;
5749 1200 : if (expr->rank == 0)
5750 : {
5751 : /* Remove dim argument. */
5752 84 : gfc_free_expr (dim_arg->expr);
5753 84 : dim_arg->expr = NULL;
5754 : }
5755 1200 : gfc_conv_intrinsic_funcall (se, expr);
5756 1200 : return;
5757 : }
5758 :
5759 132 : type = gfc_get_int_type (ikind);
5760 :
5761 : /* Initialize the result. */
5762 132 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5763 132 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5764 132 : offset = gfc_create_var (gfc_array_index_type, "offset");
5765 :
5766 132 : maskexpr = mask_arg->expr;
5767 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5768 60 : && maskexpr->symtree->n.sym->attr.dummy
5769 144 : && maskexpr->symtree->n.sym->attr.optional;
5770 :
5771 : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5772 :
5773 396 : for (i = 0 ; i < 2; i++)
5774 : {
5775 : /* Walk the arguments. */
5776 264 : arrayss = gfc_walk_expr (array_arg->expr);
5777 264 : gcc_assert (arrayss != gfc_ss_terminator);
5778 :
5779 264 : if (maskexpr && maskexpr->rank != 0)
5780 : {
5781 84 : maskss = gfc_walk_expr (maskexpr);
5782 84 : gcc_assert (maskss != gfc_ss_terminator);
5783 : }
5784 : else
5785 : maskss = NULL;
5786 :
5787 : /* Initialize the scalarizer. */
5788 264 : gfc_init_loopinfo (&loop);
5789 264 : exit_label = gfc_build_label_decl (NULL_TREE);
5790 264 : TREE_USED (exit_label) = 1;
5791 :
5792 : /* We add the mask first because the number of iterations is
5793 : taken from the last ss, and this breaks if an absent
5794 : optional argument is used for mask. */
5795 :
5796 264 : if (maskss)
5797 84 : gfc_add_ss_to_loop (&loop, maskss);
5798 264 : gfc_add_ss_to_loop (&loop, arrayss);
5799 :
5800 : /* Initialize the loop. */
5801 264 : gfc_conv_ss_startstride (&loop);
5802 264 : gfc_conv_loop_setup (&loop, &expr->where);
5803 :
5804 : /* Calculate the offset. */
5805 264 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5806 : gfc_index_one_node, loop.from[0]);
5807 264 : gfc_add_modify (&loop.pre, offset, tmp);
5808 :
5809 264 : gfc_mark_ss_chain_used (arrayss, 1);
5810 264 : if (maskss)
5811 84 : gfc_mark_ss_chain_used (maskss, 1);
5812 :
5813 : /* The first loop is for BACK=.true. */
5814 264 : if (i == 0)
5815 132 : loop.reverse[0] = GFC_REVERSE_SET;
5816 :
5817 : /* Generate the loop body. */
5818 264 : gfc_start_scalarized_body (&loop, &body);
5819 :
5820 : /* If we have an array mask, only add the element if it is
5821 : set. */
5822 264 : if (maskss)
5823 : {
5824 84 : gfc_init_se (&maskse, NULL);
5825 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5826 84 : maskse.ss = maskss;
5827 84 : gfc_conv_expr_val (&maskse, maskexpr);
5828 84 : gfc_add_block_to_block (&body, &maskse.pre);
5829 : }
5830 :
5831 : /* If the condition matches then set the return value. */
5832 264 : gfc_start_block (&block);
5833 :
5834 : /* Add the offset. */
5835 264 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5836 264 : TREE_TYPE (resvar),
5837 : loop.loopvar[0], offset);
5838 264 : gfc_add_modify (&block, resvar, tmp);
5839 : /* And break out of the loop. */
5840 264 : tmp = build1_v (GOTO_EXPR, exit_label);
5841 264 : gfc_add_expr_to_block (&block, tmp);
5842 :
5843 264 : found = gfc_finish_block (&block);
5844 :
5845 : /* Check this element. */
5846 264 : gfc_init_se (&arrayse, NULL);
5847 264 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5848 264 : arrayse.ss = arrayss;
5849 264 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5850 264 : gfc_add_block_to_block (&body, &arrayse.pre);
5851 :
5852 264 : gfc_init_se (&valuese, NULL);
5853 264 : gfc_conv_expr_val (&valuese, value_arg->expr);
5854 264 : gfc_add_block_to_block (&body, &valuese.pre);
5855 :
5856 264 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5857 : arrayse.expr, valuese.expr);
5858 :
5859 264 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5860 264 : if (maskss)
5861 : {
5862 : /* We enclose the above in if (mask) {...}. If the mask is
5863 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5864 : .OR. MASK(I)). */
5865 :
5866 84 : tree ifmask;
5867 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5868 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5869 : build_empty_stmt (input_location));
5870 : }
5871 :
5872 264 : gfc_add_expr_to_block (&body, tmp);
5873 264 : gfc_add_block_to_block (&body, &arrayse.post);
5874 :
5875 264 : gfc_trans_scalarizing_loops (&loop, &body);
5876 :
5877 : /* Add the exit label. */
5878 264 : tmp = build1_v (LABEL_EXPR, exit_label);
5879 264 : gfc_add_expr_to_block (&loop.pre, tmp);
5880 264 : gfc_start_block (&loopblock);
5881 264 : gfc_add_block_to_block (&loopblock, &loop.pre);
5882 264 : gfc_add_block_to_block (&loopblock, &loop.post);
5883 264 : if (i == 0)
5884 132 : forward_branch = gfc_finish_block (&loopblock);
5885 : else
5886 132 : back_branch = gfc_finish_block (&loopblock);
5887 :
5888 264 : gfc_cleanup_loop (&loop);
5889 : }
5890 :
5891 : /* Enclose the two loops in an IF statement. */
5892 :
5893 132 : gfc_init_se (&backse, NULL);
5894 132 : gfc_conv_expr_val (&backse, back_arg->expr);
5895 132 : gfc_add_block_to_block (&se->pre, &backse.pre);
5896 132 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5897 :
5898 : /* For a scalar mask, enclose the loop in an if statement. */
5899 132 : if (maskexpr && maskss == NULL)
5900 : {
5901 30 : tree ifmask;
5902 30 : tree if_stmt;
5903 :
5904 30 : gfc_init_se (&maskse, NULL);
5905 30 : gfc_conv_expr_val (&maskse, maskexpr);
5906 30 : gfc_init_block (&block);
5907 30 : gfc_add_expr_to_block (&block, maskse.expr);
5908 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5909 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5910 : build_empty_stmt (input_location));
5911 30 : gfc_add_expr_to_block (&block, if_stmt);
5912 30 : tmp = gfc_finish_block (&block);
5913 : }
5914 :
5915 132 : gfc_add_expr_to_block (&se->pre, tmp);
5916 132 : se->expr = convert (type, resvar);
5917 :
5918 : }
5919 :
5920 : /* Emit code for fstat, lstat and stat intrinsic subroutines. */
5921 :
5922 : static tree
5923 55 : conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5924 : {
5925 55 : stmtblock_t block;
5926 55 : gfc_se se, se_stat;
5927 55 : tree unit = NULL_TREE;
5928 55 : tree name = NULL_TREE;
5929 55 : tree slen = NULL_TREE;
5930 55 : tree vals;
5931 55 : tree arg3 = NULL_TREE;
5932 55 : tree stat = NULL_TREE ;
5933 55 : tree present = NULL_TREE;
5934 55 : tree tmp;
5935 55 : int kind;
5936 :
5937 55 : gfc_init_block (&block);
5938 55 : gfc_init_se (&se, NULL);
5939 :
5940 55 : switch (code->resolved_isym->id)
5941 : {
5942 21 : case GFC_ISYM_FSTAT:
5943 : /* Deal with the UNIT argument. */
5944 21 : gfc_conv_expr (&se, code->ext.actual->expr);
5945 21 : gfc_add_block_to_block (&block, &se.pre);
5946 21 : unit = gfc_evaluate_now (se.expr, &block);
5947 21 : unit = gfc_build_addr_expr (NULL_TREE, unit);
5948 21 : gfc_add_block_to_block (&block, &se.post);
5949 21 : break;
5950 :
5951 34 : case GFC_ISYM_LSTAT:
5952 34 : case GFC_ISYM_STAT:
5953 : /* Deal with the NAME argument. */
5954 34 : gfc_conv_expr (&se, code->ext.actual->expr);
5955 34 : gfc_conv_string_parameter (&se);
5956 34 : gfc_add_block_to_block (&block, &se.pre);
5957 34 : name = se.expr;
5958 34 : slen = se.string_length;
5959 34 : gfc_add_block_to_block (&block, &se.post);
5960 34 : break;
5961 :
5962 0 : default:
5963 0 : gcc_unreachable ();
5964 : }
5965 :
5966 : /* Deal with the VALUES argument. */
5967 55 : gfc_init_se (&se, NULL);
5968 55 : gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
5969 55 : vals = gfc_build_addr_expr (NULL_TREE, se.expr);
5970 55 : gfc_add_block_to_block (&block, &se.pre);
5971 55 : gfc_add_block_to_block (&block, &se.post);
5972 55 : kind = code->ext.actual->next->expr->ts.kind;
5973 :
5974 : /* Deal with an optional STATUS. */
5975 55 : if (code->ext.actual->next->next->expr)
5976 : {
5977 45 : gfc_init_se (&se_stat, NULL);
5978 45 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
5979 45 : stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
5980 45 : arg3 = gfc_build_addr_expr (NULL_TREE, stat);
5981 :
5982 : /* Handle case of status being an optional dummy. */
5983 45 : gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
5984 45 : if (sym->attr.dummy && sym->attr.optional)
5985 : {
5986 6 : present = gfc_conv_expr_present (sym);
5987 12 : arg3 = fold_build3_loc (input_location, COND_EXPR,
5988 6 : TREE_TYPE (arg3), present, arg3,
5989 6 : fold_convert (TREE_TYPE (arg3),
5990 : null_pointer_node));
5991 : }
5992 : }
5993 :
5994 : /* Call library function depending on KIND of VALUES argument. */
5995 55 : switch (code->resolved_isym->id)
5996 : {
5997 21 : case GFC_ISYM_FSTAT:
5998 21 : tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
5999 : break;
6000 14 : case GFC_ISYM_LSTAT:
6001 14 : tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
6002 : break;
6003 20 : case GFC_ISYM_STAT:
6004 20 : tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
6005 : break;
6006 0 : default:
6007 0 : gcc_unreachable ();
6008 : }
6009 :
6010 55 : if (code->resolved_isym->id == GFC_ISYM_FSTAT)
6011 21 : tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
6012 : stat ? arg3 : null_pointer_node);
6013 : else
6014 34 : tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
6015 : stat ? arg3 : null_pointer_node, slen);
6016 55 : gfc_add_expr_to_block (&block, tmp);
6017 :
6018 : /* Handle kind conversion of status. */
6019 55 : if (stat && stat != se_stat.expr)
6020 : {
6021 45 : stmtblock_t block2;
6022 :
6023 45 : gfc_init_block (&block2);
6024 45 : gfc_add_modify (&block2, se_stat.expr,
6025 45 : fold_convert (TREE_TYPE (se_stat.expr), stat));
6026 :
6027 45 : if (present)
6028 : {
6029 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6030 : build_empty_stmt (input_location));
6031 6 : gfc_add_expr_to_block (&block, tmp);
6032 : }
6033 : else
6034 39 : gfc_add_block_to_block (&block, &block2);
6035 : }
6036 :
6037 55 : return gfc_finish_block (&block);
6038 : }
6039 :
6040 : /* Emit code for minval or maxval intrinsic. There are many different cases
6041 : we need to handle. For performance reasons we sometimes create two
6042 : loops instead of one, where the second one is much simpler.
6043 : Examples for minval intrinsic:
6044 : 1) Result is an array, a call is generated
6045 : 2) Array mask is used and NaNs need to be supported, rank 1:
6046 : limit = Infinity;
6047 : nonempty = false;
6048 : S = from;
6049 : while (S <= to) {
6050 : if (mask[S]) {
6051 : nonempty = true;
6052 : if (a[S] <= limit) {
6053 : limit = a[S];
6054 : S++;
6055 : goto lab;
6056 : }
6057 : else
6058 : S++;
6059 : }
6060 : }
6061 : limit = nonempty ? NaN : huge (limit);
6062 : lab:
6063 : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6064 : 3) NaNs need to be supported, but it is known at compile time or cheaply
6065 : at runtime whether array is nonempty or not, rank 1:
6066 : limit = Infinity;
6067 : S = from;
6068 : while (S <= to) {
6069 : if (a[S] <= limit) {
6070 : limit = a[S];
6071 : S++;
6072 : goto lab;
6073 : }
6074 : else
6075 : S++;
6076 : }
6077 : limit = (from <= to) ? NaN : huge (limit);
6078 : lab:
6079 : while (S <= to) { limit = min (a[S], limit); S++; }
6080 : 4) Array mask is used and NaNs need to be supported, rank > 1:
6081 : limit = Infinity;
6082 : nonempty = false;
6083 : fast = false;
6084 : S1 = from1;
6085 : while (S1 <= to1) {
6086 : S2 = from2;
6087 : while (S2 <= to2) {
6088 : if (mask[S1][S2]) {
6089 : if (fast) limit = min (a[S1][S2], limit);
6090 : else {
6091 : nonempty = true;
6092 : if (a[S1][S2] <= limit) {
6093 : limit = a[S1][S2];
6094 : fast = true;
6095 : }
6096 : }
6097 : }
6098 : S2++;
6099 : }
6100 : S1++;
6101 : }
6102 : if (!fast)
6103 : limit = nonempty ? NaN : huge (limit);
6104 : 5) NaNs need to be supported, but it is known at compile time or cheaply
6105 : at runtime whether array is nonempty or not, rank > 1:
6106 : limit = Infinity;
6107 : fast = false;
6108 : S1 = from1;
6109 : while (S1 <= to1) {
6110 : S2 = from2;
6111 : while (S2 <= to2) {
6112 : if (fast) limit = min (a[S1][S2], limit);
6113 : else {
6114 : if (a[S1][S2] <= limit) {
6115 : limit = a[S1][S2];
6116 : fast = true;
6117 : }
6118 : }
6119 : S2++;
6120 : }
6121 : S1++;
6122 : }
6123 : if (!fast)
6124 : limit = (nonempty_array) ? NaN : huge (limit);
6125 : 6) NaNs aren't supported, but infinities are. Array mask is used:
6126 : limit = Infinity;
6127 : nonempty = false;
6128 : S = from;
6129 : while (S <= to) {
6130 : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6131 : S++;
6132 : }
6133 : limit = nonempty ? limit : huge (limit);
6134 : 7) Same without array mask:
6135 : limit = Infinity;
6136 : S = from;
6137 : while (S <= to) { limit = min (a[S], limit); S++; }
6138 : limit = (from <= to) ? limit : huge (limit);
6139 : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6140 : limit = huge (limit);
6141 : S = from;
6142 : while (S <= to) { limit = min (a[S], limit); S++); }
6143 : (or
6144 : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6145 : with array mask instead).
6146 : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6147 : setting limit = huge (limit); in the else branch. */
6148 :
6149 : static void
6150 2417 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6151 : {
6152 2417 : tree limit;
6153 2417 : tree type;
6154 2417 : tree tmp;
6155 2417 : tree ifbody;
6156 2417 : tree nonempty;
6157 2417 : tree nonempty_var;
6158 2417 : tree lab;
6159 2417 : tree fast;
6160 2417 : tree huge_cst = NULL, nan_cst = NULL;
6161 2417 : stmtblock_t body;
6162 2417 : stmtblock_t block, block2;
6163 2417 : gfc_loopinfo loop;
6164 2417 : gfc_actual_arglist *actual;
6165 2417 : gfc_ss *arrayss;
6166 2417 : gfc_ss *maskss;
6167 2417 : gfc_se arrayse;
6168 2417 : gfc_se maskse;
6169 2417 : gfc_expr *arrayexpr;
6170 2417 : gfc_expr *maskexpr;
6171 2417 : int n;
6172 2417 : bool optional_mask;
6173 :
6174 2417 : if (se->ss)
6175 : {
6176 0 : gfc_conv_intrinsic_funcall (se, expr);
6177 186 : return;
6178 : }
6179 :
6180 2417 : actual = expr->value.function.actual;
6181 2417 : arrayexpr = actual->expr;
6182 :
6183 2417 : if (arrayexpr->ts.type == BT_CHARACTER)
6184 : {
6185 186 : gfc_actual_arglist *dim = actual->next;
6186 186 : if (expr->rank == 0 && dim->expr != 0)
6187 : {
6188 6 : gfc_free_expr (dim->expr);
6189 6 : dim->expr = NULL;
6190 : }
6191 186 : gfc_conv_intrinsic_funcall (se, expr);
6192 186 : return;
6193 : }
6194 :
6195 2231 : type = gfc_typenode_for_spec (&expr->ts);
6196 : /* Initialize the result. */
6197 2231 : limit = gfc_create_var (type, "limit");
6198 2231 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6199 2231 : switch (expr->ts.type)
6200 : {
6201 1245 : case BT_REAL:
6202 1245 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6203 : expr->ts.kind, 0);
6204 1245 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6205 : {
6206 1241 : REAL_VALUE_TYPE real;
6207 1241 : real_inf (&real);
6208 1241 : tmp = build_real (type, real);
6209 : }
6210 : else
6211 : tmp = huge_cst;
6212 1245 : if (HONOR_NANS (DECL_MODE (limit)))
6213 1241 : nan_cst = gfc_build_nan (type, "");
6214 : break;
6215 :
6216 956 : case BT_INTEGER:
6217 956 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6218 956 : break;
6219 :
6220 30 : case BT_UNSIGNED:
6221 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6222 30 : if (op == GT_EXPR)
6223 18 : tmp = build_int_cst (type, 0);
6224 : else
6225 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6226 : expr->ts.kind);
6227 : break;
6228 :
6229 0 : default:
6230 0 : gcc_unreachable ();
6231 : }
6232 :
6233 : /* We start with the most negative possible value for MAXVAL, and the most
6234 : positive possible value for MINVAL. The most negative possible value is
6235 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6236 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6237 : with above. */
6238 2231 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6239 : {
6240 987 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6241 987 : if (huge_cst)
6242 560 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6243 560 : TREE_TYPE (huge_cst), huge_cst);
6244 : }
6245 :
6246 1005 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6247 427 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6248 : tmp, build_int_cst (type, 1));
6249 :
6250 2231 : gfc_add_modify (&se->pre, limit, tmp);
6251 :
6252 : /* Walk the arguments. */
6253 2231 : arrayss = gfc_walk_expr (arrayexpr);
6254 2231 : gcc_assert (arrayss != gfc_ss_terminator);
6255 :
6256 2231 : actual = actual->next->next;
6257 2231 : gcc_assert (actual);
6258 2231 : maskexpr = actual->expr;
6259 1572 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6260 1560 : && maskexpr->symtree->n.sym->attr.dummy
6261 2243 : && maskexpr->symtree->n.sym->attr.optional;
6262 1560 : nonempty = NULL;
6263 1572 : if (maskexpr && maskexpr->rank != 0)
6264 : {
6265 1026 : maskss = gfc_walk_expr (maskexpr);
6266 1026 : gcc_assert (maskss != gfc_ss_terminator);
6267 : }
6268 : else
6269 : {
6270 1205 : mpz_t asize;
6271 1205 : if (gfc_array_size (arrayexpr, &asize))
6272 : {
6273 678 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6274 678 : mpz_clear (asize);
6275 678 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6276 : logical_type_node, nonempty,
6277 : gfc_index_zero_node);
6278 : }
6279 1205 : maskss = NULL;
6280 : }
6281 :
6282 : /* Initialize the scalarizer. */
6283 2231 : gfc_init_loopinfo (&loop);
6284 :
6285 : /* We add the mask first because the number of iterations is taken
6286 : from the last ss, and this breaks if an absent optional argument
6287 : is used for mask. */
6288 :
6289 2231 : if (maskss)
6290 1026 : gfc_add_ss_to_loop (&loop, maskss);
6291 2231 : gfc_add_ss_to_loop (&loop, arrayss);
6292 :
6293 : /* Initialize the loop. */
6294 2231 : gfc_conv_ss_startstride (&loop);
6295 :
6296 : /* The code generated can have more than one loop in sequence (see the
6297 : comment at the function header). This doesn't work well with the
6298 : scalarizer, which changes arrays' offset when the scalarization loops
6299 : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6300 : are currently inlined in the scalar case only. As there is no dependency
6301 : to care about in that case, there is no temporary, so that we can use the
6302 : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6303 : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6304 : gfc_trans_scalarized_loop_boundary even later to restore offset.
6305 : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6306 : should eventually go away. We could either create two loops properly,
6307 : or find another way to save/restore the array offsets between the two
6308 : loops (without conflicting with temporary management), or use a single
6309 : loop minmaxval implementation. See PR 31067. */
6310 2231 : loop.temp_dim = loop.dimen;
6311 2231 : gfc_conv_loop_setup (&loop, &expr->where);
6312 :
6313 2231 : if (nonempty == NULL && maskss == NULL
6314 527 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6315 491 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6316 : loop.from[0], loop.to[0]);
6317 2231 : nonempty_var = NULL;
6318 2231 : if (nonempty == NULL
6319 2231 : && (HONOR_INFINITIES (DECL_MODE (limit))
6320 480 : || HONOR_NANS (DECL_MODE (limit))))
6321 : {
6322 582 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6323 582 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6324 582 : nonempty = nonempty_var;
6325 : }
6326 2231 : lab = NULL;
6327 2231 : fast = NULL;
6328 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6329 : {
6330 1241 : if (loop.dimen == 1)
6331 : {
6332 821 : lab = gfc_build_label_decl (NULL_TREE);
6333 821 : TREE_USED (lab) = 1;
6334 : }
6335 : else
6336 : {
6337 420 : fast = gfc_create_var (logical_type_node, "fast");
6338 420 : gfc_add_modify (&se->pre, fast, logical_false_node);
6339 : }
6340 : }
6341 :
6342 2231 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6343 2231 : if (maskss)
6344 1704 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6345 : /* Generate the loop body. */
6346 2231 : gfc_start_scalarized_body (&loop, &body);
6347 :
6348 : /* If we have a mask, only add this element if the mask is set. */
6349 2231 : if (maskss)
6350 : {
6351 1026 : gfc_init_se (&maskse, NULL);
6352 1026 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6353 1026 : maskse.ss = maskss;
6354 1026 : gfc_conv_expr_val (&maskse, maskexpr);
6355 1026 : gfc_add_block_to_block (&body, &maskse.pre);
6356 :
6357 1026 : gfc_start_block (&block);
6358 : }
6359 : else
6360 1205 : gfc_init_block (&block);
6361 :
6362 : /* Compare with the current limit. */
6363 2231 : gfc_init_se (&arrayse, NULL);
6364 2231 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6365 2231 : arrayse.ss = arrayss;
6366 2231 : gfc_conv_expr_val (&arrayse, arrayexpr);
6367 2231 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6368 2231 : gfc_add_block_to_block (&block, &arrayse.pre);
6369 :
6370 2231 : gfc_init_block (&block2);
6371 :
6372 2231 : if (nonempty_var)
6373 582 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6374 :
6375 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6376 : {
6377 1922 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6378 : logical_type_node, arrayse.expr, limit);
6379 1241 : if (lab)
6380 : {
6381 821 : stmtblock_t ifblock;
6382 821 : tree inc_loop;
6383 821 : inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6384 821 : TREE_TYPE (loop.loopvar[0]),
6385 : loop.loopvar[0], gfc_index_one_node);
6386 821 : gfc_init_block (&ifblock);
6387 821 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6388 821 : gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6389 821 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6390 821 : ifbody = gfc_finish_block (&ifblock);
6391 : }
6392 : else
6393 : {
6394 420 : stmtblock_t ifblock;
6395 :
6396 420 : gfc_init_block (&ifblock);
6397 420 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6398 420 : gfc_add_modify (&ifblock, fast, logical_true_node);
6399 420 : ifbody = gfc_finish_block (&ifblock);
6400 : }
6401 1241 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6402 : build_empty_stmt (input_location));
6403 1241 : gfc_add_expr_to_block (&block2, tmp);
6404 : }
6405 : else
6406 : {
6407 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6408 : signed zeros. */
6409 1535 : tmp = fold_build2_loc (input_location,
6410 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6411 : type, arrayse.expr, limit);
6412 990 : gfc_add_modify (&block2, limit, tmp);
6413 : }
6414 :
6415 2231 : if (fast)
6416 : {
6417 420 : tree elsebody = gfc_finish_block (&block2);
6418 :
6419 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6420 : signed zeros. */
6421 420 : if (HONOR_NANS (DECL_MODE (limit)))
6422 : {
6423 420 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6424 : arrayse.expr, limit);
6425 420 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6426 420 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6427 : build_empty_stmt (input_location));
6428 : }
6429 : else
6430 : {
6431 0 : tmp = fold_build2_loc (input_location,
6432 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6433 : type, arrayse.expr, limit);
6434 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6435 : }
6436 420 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6437 420 : gfc_add_expr_to_block (&block, tmp);
6438 : }
6439 : else
6440 1811 : gfc_add_block_to_block (&block, &block2);
6441 :
6442 2231 : gfc_add_block_to_block (&block, &arrayse.post);
6443 :
6444 2231 : tmp = gfc_finish_block (&block);
6445 2231 : if (maskss)
6446 : {
6447 : /* We enclose the above in if (mask) {...}. If the mask is an
6448 : optional argument, generate IF (.NOT. PRESENT(MASK)
6449 : .OR. MASK(I)). */
6450 1026 : tree ifmask;
6451 1026 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6452 1026 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6453 : build_empty_stmt (input_location));
6454 : }
6455 2231 : gfc_add_expr_to_block (&body, tmp);
6456 :
6457 2231 : if (lab)
6458 : {
6459 821 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6460 :
6461 821 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6462 : nan_cst, huge_cst);
6463 821 : gfc_add_modify (&loop.code[0], limit, tmp);
6464 821 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6465 :
6466 : /* If we have a mask, only add this element if the mask is set. */
6467 821 : if (maskss)
6468 : {
6469 348 : gfc_init_se (&maskse, NULL);
6470 348 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6471 348 : maskse.ss = maskss;
6472 348 : gfc_conv_expr_val (&maskse, maskexpr);
6473 348 : gfc_add_block_to_block (&body, &maskse.pre);
6474 :
6475 348 : gfc_start_block (&block);
6476 : }
6477 : else
6478 473 : gfc_init_block (&block);
6479 :
6480 : /* Compare with the current limit. */
6481 821 : gfc_init_se (&arrayse, NULL);
6482 821 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6483 821 : arrayse.ss = arrayss;
6484 821 : gfc_conv_expr_val (&arrayse, arrayexpr);
6485 821 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6486 821 : gfc_add_block_to_block (&block, &arrayse.pre);
6487 :
6488 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6489 : signed zeros. */
6490 821 : if (HONOR_NANS (DECL_MODE (limit)))
6491 : {
6492 821 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6493 : arrayse.expr, limit);
6494 821 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6495 821 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6496 : build_empty_stmt (input_location));
6497 821 : gfc_add_expr_to_block (&block, tmp);
6498 : }
6499 : else
6500 : {
6501 0 : tmp = fold_build2_loc (input_location,
6502 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6503 : type, arrayse.expr, limit);
6504 0 : gfc_add_modify (&block, limit, tmp);
6505 : }
6506 :
6507 821 : gfc_add_block_to_block (&block, &arrayse.post);
6508 :
6509 821 : tmp = gfc_finish_block (&block);
6510 821 : if (maskss)
6511 : /* We enclose the above in if (mask) {...}. */
6512 : {
6513 348 : tree ifmask;
6514 348 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6515 348 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6516 : build_empty_stmt (input_location));
6517 : }
6518 :
6519 821 : gfc_add_expr_to_block (&body, tmp);
6520 : /* Avoid initializing loopvar[0] again, it should be left where
6521 : it finished by the first loop. */
6522 821 : loop.from[0] = loop.loopvar[0];
6523 : }
6524 2231 : gfc_trans_scalarizing_loops (&loop, &body);
6525 :
6526 2231 : if (fast)
6527 : {
6528 420 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6529 : nan_cst, huge_cst);
6530 420 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6531 420 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6532 : ifbody);
6533 420 : gfc_add_expr_to_block (&loop.pre, tmp);
6534 : }
6535 1811 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6536 : {
6537 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6538 : huge_cst);
6539 0 : gfc_add_modify (&loop.pre, limit, tmp);
6540 : }
6541 :
6542 : /* For a scalar mask, enclose the loop in an if statement. */
6543 2231 : if (maskexpr && maskss == NULL)
6544 : {
6545 546 : tree else_stmt;
6546 546 : tree ifmask;
6547 :
6548 546 : gfc_init_se (&maskse, NULL);
6549 546 : gfc_conv_expr_val (&maskse, maskexpr);
6550 546 : gfc_init_block (&block);
6551 546 : gfc_add_block_to_block (&block, &loop.pre);
6552 546 : gfc_add_block_to_block (&block, &loop.post);
6553 546 : tmp = gfc_finish_block (&block);
6554 :
6555 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6556 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6557 : else
6558 192 : else_stmt = build_empty_stmt (input_location);
6559 :
6560 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6561 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6562 546 : gfc_add_expr_to_block (&block, tmp);
6563 546 : gfc_add_block_to_block (&se->pre, &block);
6564 : }
6565 : else
6566 : {
6567 1685 : gfc_add_block_to_block (&se->pre, &loop.pre);
6568 1685 : gfc_add_block_to_block (&se->pre, &loop.post);
6569 : }
6570 :
6571 2231 : gfc_cleanup_loop (&loop);
6572 :
6573 2231 : se->expr = limit;
6574 : }
6575 :
6576 : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6577 : static void
6578 145 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6579 : {
6580 145 : tree args[2];
6581 145 : tree type;
6582 145 : tree tmp;
6583 :
6584 145 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6585 145 : type = TREE_TYPE (args[0]);
6586 :
6587 : /* Optionally generate code for runtime argument check. */
6588 145 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6589 : {
6590 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6591 : logical_type_node, args[1],
6592 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6593 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6594 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6595 : logical_type_node, args[1], nbits);
6596 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6597 : logical_type_node, below, above);
6598 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6599 : "POS argument (%ld) out of range 0:%ld "
6600 : "in intrinsic BTEST",
6601 : fold_convert (long_integer_type_node, args[1]),
6602 : fold_convert (long_integer_type_node, nbits));
6603 : }
6604 :
6605 145 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6606 : build_int_cst (type, 1), args[1]);
6607 145 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6608 145 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6609 : build_int_cst (type, 0));
6610 145 : type = gfc_typenode_for_spec (&expr->ts);
6611 145 : se->expr = convert (type, tmp);
6612 145 : }
6613 :
6614 :
6615 : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6616 : static void
6617 216 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6618 : {
6619 216 : tree args[2];
6620 :
6621 216 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6622 :
6623 : /* Convert both arguments to the unsigned type of the same size. */
6624 216 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6625 216 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6626 :
6627 : /* If they have unequal type size, convert to the larger one. */
6628 216 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6629 216 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6630 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6631 216 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6632 216 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6633 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6634 :
6635 : /* Now, we compare them. */
6636 216 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6637 : args[0], args[1]);
6638 216 : }
6639 :
6640 :
6641 : /* Generate code to perform the specified operation. */
6642 : static void
6643 1915 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6644 : {
6645 1915 : tree args[2];
6646 :
6647 1915 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6648 1915 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6649 : args[0], args[1]);
6650 1915 : }
6651 :
6652 : /* Bitwise not. */
6653 : static void
6654 230 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6655 : {
6656 230 : tree arg;
6657 :
6658 230 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6659 230 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6660 230 : TREE_TYPE (arg), arg);
6661 230 : }
6662 :
6663 :
6664 : /* Generate code for OUT_OF_RANGE. */
6665 : static void
6666 468 : gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6667 : {
6668 468 : tree *args;
6669 468 : tree type;
6670 468 : tree tmp = NULL_TREE, tmp1, tmp2;
6671 468 : unsigned int num_args;
6672 468 : int k;
6673 468 : gfc_se rnd_se;
6674 468 : gfc_actual_arglist *arg = expr->value.function.actual;
6675 468 : gfc_expr *x = arg->expr;
6676 468 : gfc_expr *mold = arg->next->expr;
6677 :
6678 468 : num_args = gfc_intrinsic_argument_list_length (expr);
6679 468 : args = XALLOCAVEC (tree, num_args);
6680 :
6681 468 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6682 :
6683 468 : gfc_init_se (&rnd_se, NULL);
6684 :
6685 468 : if (num_args == 3)
6686 : {
6687 : /* The ROUND argument is optional and shall appear only if X is
6688 : of type real and MOLD is of type integer (see edit F23/004). */
6689 270 : gfc_expr *round = arg->next->next->expr;
6690 270 : gfc_conv_expr (&rnd_se, round);
6691 :
6692 270 : if (round->expr_type == EXPR_VARIABLE
6693 198 : && round->symtree->n.sym->attr.dummy
6694 30 : && round->symtree->n.sym->attr.optional)
6695 : {
6696 30 : tree present = gfc_conv_expr_present (round->symtree->n.sym);
6697 30 : rnd_se.expr = build3_loc (input_location, COND_EXPR,
6698 : logical_type_node, present,
6699 : rnd_se.expr, logical_false_node);
6700 30 : gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6701 : }
6702 : }
6703 : else
6704 : {
6705 : /* If ROUND is absent, it is equivalent to having the value false. */
6706 198 : rnd_se.expr = logical_false_node;
6707 : }
6708 :
6709 468 : type = TREE_TYPE (args[0]);
6710 468 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6711 :
6712 468 : switch (x->ts.type)
6713 : {
6714 378 : case BT_REAL:
6715 : /* X may be IEEE infinity or NaN, but the representation of MOLD may not
6716 : support infinity or NaN. */
6717 378 : tree finite;
6718 378 : finite = build_call_expr_loc (input_location,
6719 : builtin_decl_explicit (BUILT_IN_ISFINITE),
6720 : 1, args[0]);
6721 378 : finite = convert (logical_type_node, finite);
6722 :
6723 378 : if (mold->ts.type == BT_REAL)
6724 : {
6725 24 : tmp1 = build1 (ABS_EXPR, type, args[0]);
6726 24 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6727 : mold->ts.kind, 0);
6728 24 : tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6729 : convert (type, tmp2));
6730 :
6731 : /* Check if MOLD representation supports infinity or NaN. */
6732 24 : bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6733 24 : || HONOR_NANS (TREE_TYPE (args[1])));
6734 24 : tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6735 : infnan ? logical_false_node : logical_true_node);
6736 : }
6737 : else
6738 : {
6739 354 : tree rounded;
6740 354 : tree decl;
6741 :
6742 354 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
6743 354 : gcc_assert (decl != NULL_TREE);
6744 :
6745 : /* Round or truncate argument X, depending on the optional argument
6746 : ROUND (default: .false.). */
6747 354 : tmp1 = build_round_expr (args[0], type);
6748 354 : tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6749 354 : rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6750 :
6751 354 : if (mold->ts.type == BT_INTEGER)
6752 : {
6753 180 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6754 : x->ts.kind);
6755 180 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6756 : x->ts.kind);
6757 : }
6758 174 : else if (mold->ts.type == BT_UNSIGNED)
6759 : {
6760 174 : tmp1 = build_real_from_int_cst (type, integer_zero_node);
6761 174 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6762 : x->ts.kind);
6763 : }
6764 : else
6765 0 : gcc_unreachable ();
6766 :
6767 354 : tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6768 : convert (type, tmp1));
6769 354 : tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6770 : convert (type, tmp2));
6771 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6772 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6773 : build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6774 : tmp);
6775 : }
6776 : break;
6777 :
6778 48 : case BT_INTEGER:
6779 48 : if (mold->ts.type == BT_INTEGER)
6780 : {
6781 12 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6782 : x->ts.kind);
6783 12 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6784 : x->ts.kind);
6785 12 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6786 : convert (type, tmp1));
6787 12 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6788 : convert (type, tmp2));
6789 12 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6790 : }
6791 36 : else if (mold->ts.type == BT_UNSIGNED)
6792 : {
6793 36 : int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6794 36 : tmp = build_int_cst (type, 0);
6795 36 : tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6796 36 : if (mpz_cmp (gfc_integer_kinds[i].huge,
6797 36 : gfc_unsigned_kinds[k].huge) > 0)
6798 : {
6799 0 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6800 : x->ts.kind);
6801 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6802 : convert (type, tmp2));
6803 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6804 : }
6805 : }
6806 0 : else if (mold->ts.type == BT_REAL)
6807 : {
6808 0 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6809 : mold->ts.kind, 0);
6810 0 : tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6811 0 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6812 : convert (type, tmp1));
6813 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6814 : convert (type, tmp2));
6815 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6816 : }
6817 : else
6818 0 : gcc_unreachable ();
6819 : break;
6820 :
6821 42 : case BT_UNSIGNED:
6822 42 : if (mold->ts.type == BT_UNSIGNED)
6823 : {
6824 12 : tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6825 : x->ts.kind);
6826 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6827 : convert (type, tmp));
6828 : }
6829 30 : else if (mold->ts.type == BT_INTEGER)
6830 : {
6831 18 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6832 : x->ts.kind);
6833 18 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6834 : convert (type, tmp));
6835 : }
6836 12 : else if (mold->ts.type == BT_REAL)
6837 : {
6838 12 : tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6839 : mold->ts.kind, 0);
6840 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6841 : convert (type, tmp));
6842 : }
6843 : else
6844 0 : gcc_unreachable ();
6845 : break;
6846 :
6847 0 : default:
6848 0 : gcc_unreachable ();
6849 : }
6850 :
6851 468 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6852 468 : }
6853 :
6854 :
6855 : /* Set or clear a single bit. */
6856 : static void
6857 306 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6858 : {
6859 306 : tree args[2];
6860 306 : tree type;
6861 306 : tree tmp;
6862 306 : enum tree_code op;
6863 :
6864 306 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6865 306 : type = TREE_TYPE (args[0]);
6866 :
6867 : /* Optionally generate code for runtime argument check. */
6868 306 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6869 : {
6870 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6871 : logical_type_node, args[1],
6872 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6873 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6874 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6875 : logical_type_node, args[1], nbits);
6876 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6877 : logical_type_node, below, above);
6878 12 : size_t len_name = strlen (expr->value.function.isym->name);
6879 12 : char *name = XALLOCAVEC (char, len_name + 1);
6880 72 : for (size_t i = 0; i < len_name; i++)
6881 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6882 12 : name[len_name] = '\0';
6883 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6884 : gfc_build_cstring_const (name));
6885 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6886 : "POS argument (%ld) out of range 0:%ld "
6887 : "in intrinsic %s",
6888 : fold_convert (long_integer_type_node, args[1]),
6889 : fold_convert (long_integer_type_node, nbits),
6890 : iname);
6891 : }
6892 :
6893 306 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6894 : build_int_cst (type, 1), args[1]);
6895 306 : if (set)
6896 : op = BIT_IOR_EXPR;
6897 : else
6898 : {
6899 168 : op = BIT_AND_EXPR;
6900 168 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6901 : }
6902 306 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6903 306 : }
6904 :
6905 : /* Extract a sequence of bits.
6906 : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6907 : static void
6908 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6909 : {
6910 27 : tree args[3];
6911 27 : tree type;
6912 27 : tree tmp;
6913 27 : tree mask;
6914 27 : tree num_bits, cond;
6915 :
6916 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6917 27 : type = TREE_TYPE (args[0]);
6918 :
6919 : /* Optionally generate code for runtime argument check. */
6920 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6921 : {
6922 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6923 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6924 12 : tree nbits = build_int_cst (long_integer_type_node,
6925 12 : TYPE_PRECISION (type));
6926 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6927 : logical_type_node, args[1],
6928 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6929 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
6930 : logical_type_node, tmp1, nbits);
6931 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6932 : logical_type_node, below, above);
6933 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6934 : "POS argument (%ld) out of range 0:%ld "
6935 : "in intrinsic IBITS", tmp1, nbits);
6936 12 : below = fold_build2_loc (input_location, LT_EXPR,
6937 : logical_type_node, args[2],
6938 12 : build_int_cst (TREE_TYPE (args[2]), 0));
6939 12 : above = fold_build2_loc (input_location, GT_EXPR,
6940 : logical_type_node, tmp2, nbits);
6941 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6942 : logical_type_node, below, above);
6943 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6944 : "LEN argument (%ld) out of range 0:%ld "
6945 : "in intrinsic IBITS", tmp2, nbits);
6946 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
6947 : long_integer_type_node, tmp1, tmp2);
6948 12 : scond = fold_build2_loc (input_location, GT_EXPR,
6949 : logical_type_node, above, nbits);
6950 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6951 : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6952 : "in intrinsic IBITS", tmp1, tmp2, nbits);
6953 : }
6954 :
6955 : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6956 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6957 : special case. See also gfc_conv_intrinsic_ishft (). */
6958 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6959 :
6960 27 : mask = build_int_cst (type, -1);
6961 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6962 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6963 : num_bits);
6964 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6965 : build_int_cst (type, 0), mask);
6966 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6967 :
6968 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6969 :
6970 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6971 27 : }
6972 :
6973 : static void
6974 492 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6975 : bool arithmetic)
6976 : {
6977 492 : tree args[2], type, num_bits, cond;
6978 492 : tree bigshift;
6979 492 : bool do_convert = false;
6980 :
6981 492 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6982 :
6983 492 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6984 492 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6985 492 : type = TREE_TYPE (args[0]);
6986 :
6987 492 : if (!arithmetic)
6988 : {
6989 390 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
6990 390 : do_convert = true;
6991 : }
6992 : else
6993 102 : gcc_assert (right_shift);
6994 :
6995 492 : if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
6996 : {
6997 30 : do_convert = true;
6998 30 : args[0] = fold_convert (signed_type_for (type), args[0]);
6999 : }
7000 :
7001 816 : se->expr = fold_build2_loc (input_location,
7002 : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
7003 492 : TREE_TYPE (args[0]), args[0], args[1]);
7004 :
7005 492 : if (do_convert)
7006 420 : se->expr = fold_convert (type, se->expr);
7007 :
7008 492 : if (!arithmetic)
7009 390 : bigshift = build_int_cst (type, 0);
7010 : else
7011 : {
7012 102 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
7013 : logical_type_node, args[0],
7014 102 : build_int_cst (TREE_TYPE (args[0]), 0));
7015 102 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
7016 : build_int_cst (type, 0),
7017 : build_int_cst (type, -1));
7018 : }
7019 :
7020 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7021 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7022 : special case. */
7023 492 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7024 :
7025 : /* Optionally generate code for runtime argument check. */
7026 492 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7027 : {
7028 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
7029 : logical_type_node, args[1],
7030 30 : build_int_cst (TREE_TYPE (args[1]), 0));
7031 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
7032 : logical_type_node, args[1], num_bits);
7033 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7034 : logical_type_node, below, above);
7035 30 : size_t len_name = strlen (expr->value.function.isym->name);
7036 30 : char *name = XALLOCAVEC (char, len_name + 1);
7037 210 : for (size_t i = 0; i < len_name; i++)
7038 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
7039 30 : name[len_name] = '\0';
7040 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
7041 : gfc_build_cstring_const (name));
7042 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7043 : "SHIFT argument (%ld) out of range 0:%ld "
7044 : "in intrinsic %s",
7045 : fold_convert (long_integer_type_node, args[1]),
7046 : fold_convert (long_integer_type_node, num_bits),
7047 : iname);
7048 : }
7049 :
7050 492 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7051 : args[1], num_bits);
7052 :
7053 492 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7054 : bigshift, se->expr);
7055 492 : }
7056 :
7057 : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7058 : ? 0
7059 : : ((shift >= 0) ? i << shift : i >> -shift)
7060 : where all shifts are logical shifts. */
7061 : static void
7062 318 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7063 : {
7064 318 : tree args[2];
7065 318 : tree type;
7066 318 : tree utype;
7067 318 : tree tmp;
7068 318 : tree width;
7069 318 : tree num_bits;
7070 318 : tree cond;
7071 318 : tree lshift;
7072 318 : tree rshift;
7073 :
7074 318 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7075 :
7076 318 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7077 318 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7078 :
7079 318 : type = TREE_TYPE (args[0]);
7080 318 : utype = unsigned_type_for (type);
7081 :
7082 318 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7083 : args[1]);
7084 :
7085 : /* Left shift if positive. */
7086 318 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7087 :
7088 : /* Right shift if negative.
7089 : We convert to an unsigned type because we want a logical shift.
7090 : The standard doesn't define the case of shifting negative
7091 : numbers, and we try to be compatible with other compilers, most
7092 : notably g77, here. */
7093 318 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7094 : utype, convert (utype, args[0]), width));
7095 :
7096 318 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7097 318 : build_int_cst (TREE_TYPE (args[1]), 0));
7098 318 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7099 :
7100 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7101 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7102 : special case. */
7103 318 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7104 :
7105 : /* Optionally generate code for runtime argument check. */
7106 318 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7107 : {
7108 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7109 : logical_type_node, width, num_bits);
7110 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7111 : "SHIFT argument (%ld) out of range -%ld:%ld "
7112 : "in intrinsic ISHFT",
7113 : fold_convert (long_integer_type_node, args[1]),
7114 : fold_convert (long_integer_type_node, num_bits),
7115 : fold_convert (long_integer_type_node, num_bits));
7116 : }
7117 :
7118 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7119 : num_bits);
7120 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7121 : build_int_cst (type, 0), tmp);
7122 318 : }
7123 :
7124 :
7125 : /* Circular shift. AKA rotate or barrel shift. */
7126 :
7127 : static void
7128 658 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7129 : {
7130 658 : tree *args;
7131 658 : tree type;
7132 658 : tree tmp;
7133 658 : tree lrot;
7134 658 : tree rrot;
7135 658 : tree zero;
7136 658 : tree nbits;
7137 658 : unsigned int num_args;
7138 :
7139 658 : num_args = gfc_intrinsic_argument_list_length (expr);
7140 658 : args = XALLOCAVEC (tree, num_args);
7141 :
7142 658 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7143 :
7144 658 : type = TREE_TYPE (args[0]);
7145 658 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7146 :
7147 658 : if (num_args == 3)
7148 : {
7149 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
7150 :
7151 : /* Use a library function for the 3 parameter version. */
7152 550 : tree int4type = gfc_get_int_type (4);
7153 :
7154 : /* Treat optional SIZE argument when it is passed as an optional
7155 : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7156 550 : if (size->expr_type == EXPR_VARIABLE
7157 438 : && size->symtree->n.sym->attr.dummy
7158 36 : && size->symtree->n.sym->attr.optional)
7159 : {
7160 36 : tree type_of_size = TREE_TYPE (args[2]);
7161 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
7162 36 : gfc_conv_expr_present (size->symtree->n.sym),
7163 : args[2], fold_convert (type_of_size, nbits));
7164 : }
7165 :
7166 : /* We convert the first argument to at least 4 bytes, and
7167 : convert back afterwards. This removes the need for library
7168 : functions for all argument sizes, and function will be
7169 : aligned to at least 32 bits, so there's no loss. */
7170 550 : if (expr->ts.kind < 4)
7171 242 : args[0] = convert (int4type, args[0]);
7172 :
7173 : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7174 : need loads of library functions. They cannot have values >
7175 : BIT_SIZE (I) so the conversion is safe. */
7176 550 : args[1] = convert (int4type, args[1]);
7177 550 : args[2] = convert (int4type, args[2]);
7178 :
7179 : /* Optionally generate code for runtime argument check. */
7180 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7181 : {
7182 18 : tree size = fold_convert (long_integer_type_node, args[2]);
7183 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
7184 : logical_type_node, size,
7185 18 : build_int_cst (TREE_TYPE (args[1]), 0));
7186 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
7187 : logical_type_node, size, nbits);
7188 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7189 : logical_type_node, below, above);
7190 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7191 : "SIZE argument (%ld) out of range 1:%ld "
7192 : "in intrinsic ISHFTC", size, nbits);
7193 18 : tree width = fold_convert (long_integer_type_node, args[1]);
7194 18 : width = fold_build1_loc (input_location, ABS_EXPR,
7195 : long_integer_type_node, width);
7196 18 : scond = fold_build2_loc (input_location, GT_EXPR,
7197 : logical_type_node, width, size);
7198 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7199 : "SHIFT argument (%ld) out of range -%ld:%ld "
7200 : "in intrinsic ISHFTC",
7201 : fold_convert (long_integer_type_node, args[1]),
7202 : size, size);
7203 : }
7204 :
7205 550 : switch (expr->ts.kind)
7206 : {
7207 426 : case 1:
7208 426 : case 2:
7209 426 : case 4:
7210 426 : tmp = gfor_fndecl_math_ishftc4;
7211 426 : break;
7212 124 : case 8:
7213 124 : tmp = gfor_fndecl_math_ishftc8;
7214 124 : break;
7215 0 : case 16:
7216 0 : tmp = gfor_fndecl_math_ishftc16;
7217 0 : break;
7218 0 : default:
7219 0 : gcc_unreachable ();
7220 : }
7221 550 : se->expr = build_call_expr_loc (input_location,
7222 : tmp, 3, args[0], args[1], args[2]);
7223 : /* Convert the result back to the original type, if we extended
7224 : the first argument's width above. */
7225 550 : if (expr->ts.kind < 4)
7226 242 : se->expr = convert (type, se->expr);
7227 :
7228 550 : return;
7229 : }
7230 :
7231 : /* Evaluate arguments only once. */
7232 108 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7233 108 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7234 :
7235 : /* Optionally generate code for runtime argument check. */
7236 108 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7237 : {
7238 12 : tree width = fold_convert (long_integer_type_node, args[1]);
7239 12 : width = fold_build1_loc (input_location, ABS_EXPR,
7240 : long_integer_type_node, width);
7241 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7242 : logical_type_node, width, nbits);
7243 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7244 : "SHIFT argument (%ld) out of range -%ld:%ld "
7245 : "in intrinsic ISHFTC",
7246 : fold_convert (long_integer_type_node, args[1]),
7247 : nbits, nbits);
7248 : }
7249 :
7250 : /* Rotate left if positive. */
7251 108 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7252 :
7253 : /* Rotate right if negative. */
7254 108 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7255 : args[1]);
7256 108 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7257 :
7258 108 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
7259 108 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7260 : zero);
7261 108 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7262 :
7263 : /* Do nothing if shift == 0. */
7264 108 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7265 : zero);
7266 108 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7267 : rrot);
7268 : }
7269 :
7270 :
7271 : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7272 : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7273 :
7274 : The conditional expression is necessary because the result of LEADZ(0)
7275 : is defined, but the result of __builtin_clz(0) is undefined for most
7276 : targets.
7277 :
7278 : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7279 : difference in bit size between the argument of LEADZ and the C int. */
7280 :
7281 : static void
7282 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7283 : {
7284 270 : tree arg;
7285 270 : tree arg_type;
7286 270 : tree cond;
7287 270 : tree result_type;
7288 270 : tree leadz;
7289 270 : tree bit_size;
7290 270 : tree tmp;
7291 270 : tree func;
7292 270 : int s, argsize;
7293 :
7294 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7295 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7296 :
7297 : /* Which variant of __builtin_clz* should we call? */
7298 270 : if (argsize <= INT_TYPE_SIZE)
7299 : {
7300 183 : arg_type = unsigned_type_node;
7301 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7302 : }
7303 87 : else if (argsize <= LONG_TYPE_SIZE)
7304 : {
7305 57 : arg_type = long_unsigned_type_node;
7306 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7307 : }
7308 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7309 : {
7310 0 : arg_type = long_long_unsigned_type_node;
7311 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7312 : }
7313 : else
7314 : {
7315 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7316 30 : arg_type = gfc_build_uint_type (argsize);
7317 30 : func = NULL_TREE;
7318 : }
7319 :
7320 : /* Convert the actual argument twice: first, to the unsigned type of the
7321 : same size; then, to the proper argument type for the built-in
7322 : function. But the return type is of the default INTEGER kind. */
7323 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7324 270 : arg = fold_convert (arg_type, arg);
7325 270 : arg = gfc_evaluate_now (arg, &se->pre);
7326 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7327 :
7328 : /* Compute LEADZ for the case i .ne. 0. */
7329 270 : if (func)
7330 : {
7331 240 : s = TYPE_PRECISION (arg_type) - argsize;
7332 240 : tmp = fold_convert (result_type,
7333 : build_call_expr_loc (input_location, func,
7334 : 1, arg));
7335 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7336 240 : tmp, build_int_cst (result_type, s));
7337 : }
7338 : else
7339 : {
7340 : /* We end up here if the argument type is larger than 'long long'.
7341 : We generate this code:
7342 :
7343 : if (x & (ULL_MAX << ULL_SIZE) != 0)
7344 : return clzll ((unsigned long long) (x >> ULLSIZE));
7345 : else
7346 : return ULL_SIZE + clzll ((unsigned long long) x);
7347 : where ULL_MAX is the largest value that a ULL_MAX can hold
7348 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7349 : is the bit-size of the long long type (64 in this example). */
7350 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7351 :
7352 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7353 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7354 : long_long_unsigned_type_node,
7355 : build_int_cst (long_long_unsigned_type_node,
7356 : 0));
7357 :
7358 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7359 : fold_convert (arg_type, ullmax), ullsize);
7360 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7361 : arg, cond);
7362 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7363 : cond, build_int_cst (arg_type, 0));
7364 :
7365 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7366 : arg, ullsize);
7367 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7368 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7369 30 : tmp1 = fold_convert (result_type,
7370 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7371 :
7372 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7373 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7374 30 : tmp2 = fold_convert (result_type,
7375 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7376 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7377 : tmp2, ullsize);
7378 :
7379 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7380 : cond, tmp1, tmp2);
7381 : }
7382 :
7383 : /* Build BIT_SIZE. */
7384 270 : bit_size = build_int_cst (result_type, argsize);
7385 :
7386 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7387 : arg, build_int_cst (arg_type, 0));
7388 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7389 : bit_size, leadz);
7390 270 : }
7391 :
7392 :
7393 : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7394 :
7395 : The conditional expression is necessary because the result of TRAILZ(0)
7396 : is defined, but the result of __builtin_ctz(0) is undefined for most
7397 : targets. */
7398 :
7399 : static void
7400 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7401 : {
7402 282 : tree arg;
7403 282 : tree arg_type;
7404 282 : tree cond;
7405 282 : tree result_type;
7406 282 : tree trailz;
7407 282 : tree bit_size;
7408 282 : tree func;
7409 282 : int argsize;
7410 :
7411 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7412 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7413 :
7414 : /* Which variant of __builtin_ctz* should we call? */
7415 282 : if (argsize <= INT_TYPE_SIZE)
7416 : {
7417 195 : arg_type = unsigned_type_node;
7418 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7419 : }
7420 87 : else if (argsize <= LONG_TYPE_SIZE)
7421 : {
7422 57 : arg_type = long_unsigned_type_node;
7423 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7424 : }
7425 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7426 : {
7427 0 : arg_type = long_long_unsigned_type_node;
7428 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7429 : }
7430 : else
7431 : {
7432 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7433 30 : arg_type = gfc_build_uint_type (argsize);
7434 30 : func = NULL_TREE;
7435 : }
7436 :
7437 : /* Convert the actual argument twice: first, to the unsigned type of the
7438 : same size; then, to the proper argument type for the built-in
7439 : function. But the return type is of the default INTEGER kind. */
7440 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7441 282 : arg = fold_convert (arg_type, arg);
7442 282 : arg = gfc_evaluate_now (arg, &se->pre);
7443 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7444 :
7445 : /* Compute TRAILZ for the case i .ne. 0. */
7446 282 : if (func)
7447 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7448 : func, 1, arg));
7449 : else
7450 : {
7451 : /* We end up here if the argument type is larger than 'long long'.
7452 : We generate this code:
7453 :
7454 : if ((x & ULL_MAX) == 0)
7455 : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7456 : else
7457 : return ctzll ((unsigned long long) x);
7458 :
7459 : where ULL_MAX is the largest value that a ULL_MAX can hold
7460 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7461 : is the bit-size of the long long type (64 in this example). */
7462 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7463 :
7464 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7465 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7466 : long_long_unsigned_type_node,
7467 : build_int_cst (long_long_unsigned_type_node, 0));
7468 :
7469 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7470 : fold_convert (arg_type, ullmax));
7471 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7472 : build_int_cst (arg_type, 0));
7473 :
7474 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7475 : arg, ullsize);
7476 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7477 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7478 30 : tmp1 = fold_convert (result_type,
7479 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7480 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7481 : tmp1, ullsize);
7482 :
7483 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7484 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7485 30 : tmp2 = fold_convert (result_type,
7486 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7487 :
7488 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7489 : cond, tmp1, tmp2);
7490 : }
7491 :
7492 : /* Build BIT_SIZE. */
7493 282 : bit_size = build_int_cst (result_type, argsize);
7494 :
7495 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7496 : arg, build_int_cst (arg_type, 0));
7497 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7498 : bit_size, trailz);
7499 282 : }
7500 :
7501 : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7502 : for types larger than "long long", we call the long long built-in for
7503 : the lower and higher bits and combine the result. */
7504 :
7505 : static void
7506 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7507 : {
7508 134 : tree arg;
7509 134 : tree arg_type;
7510 134 : tree result_type;
7511 134 : tree func;
7512 134 : int argsize;
7513 :
7514 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7515 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7516 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7517 :
7518 : /* Which variant of the builtin should we call? */
7519 134 : if (argsize <= INT_TYPE_SIZE)
7520 : {
7521 108 : arg_type = unsigned_type_node;
7522 198 : func = builtin_decl_explicit (parity
7523 : ? BUILT_IN_PARITY
7524 : : BUILT_IN_POPCOUNT);
7525 : }
7526 26 : else if (argsize <= LONG_TYPE_SIZE)
7527 : {
7528 12 : arg_type = long_unsigned_type_node;
7529 18 : func = builtin_decl_explicit (parity
7530 : ? BUILT_IN_PARITYL
7531 : : BUILT_IN_POPCOUNTL);
7532 : }
7533 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7534 : {
7535 0 : arg_type = long_long_unsigned_type_node;
7536 0 : func = builtin_decl_explicit (parity
7537 : ? BUILT_IN_PARITYLL
7538 : : BUILT_IN_POPCOUNTLL);
7539 : }
7540 : else
7541 : {
7542 : /* Our argument type is larger than 'long long', which mean none
7543 : of the POPCOUNT builtins covers it. We thus call the 'long long'
7544 : variant multiple times, and add the results. */
7545 14 : tree utype, arg2, call1, call2;
7546 :
7547 : /* For now, we only cover the case where argsize is twice as large
7548 : as 'long long'. */
7549 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7550 :
7551 21 : func = builtin_decl_explicit (parity
7552 : ? BUILT_IN_PARITYLL
7553 : : BUILT_IN_POPCOUNTLL);
7554 :
7555 : /* Convert it to an integer, and store into a variable. */
7556 14 : utype = gfc_build_uint_type (argsize);
7557 14 : arg = fold_convert (utype, arg);
7558 14 : arg = gfc_evaluate_now (arg, &se->pre);
7559 :
7560 : /* Call the builtin twice. */
7561 14 : call1 = build_call_expr_loc (input_location, func, 1,
7562 : fold_convert (long_long_unsigned_type_node,
7563 : arg));
7564 :
7565 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7566 : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7567 14 : call2 = build_call_expr_loc (input_location, func, 1,
7568 : fold_convert (long_long_unsigned_type_node,
7569 : arg2));
7570 :
7571 : /* Combine the results. */
7572 14 : if (parity)
7573 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7574 : integer_type_node, call1, call2);
7575 : else
7576 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7577 : integer_type_node, call1, call2);
7578 :
7579 14 : se->expr = convert (result_type, se->expr);
7580 14 : return;
7581 : }
7582 :
7583 : /* Convert the actual argument twice: first, to the unsigned type of the
7584 : same size; then, to the proper argument type for the built-in
7585 : function. */
7586 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7587 120 : arg = fold_convert (arg_type, arg);
7588 :
7589 120 : se->expr = fold_convert (result_type,
7590 : build_call_expr_loc (input_location, func, 1, arg));
7591 : }
7592 :
7593 :
7594 : /* Process an intrinsic with unspecified argument-types that has an optional
7595 : argument (which could be of type character), e.g. EOSHIFT. For those, we
7596 : need to append the string length of the optional argument if it is not
7597 : present and the type is really character.
7598 : primary specifies the position (starting at 1) of the non-optional argument
7599 : specifying the type and optional gives the position of the optional
7600 : argument in the arglist. */
7601 :
7602 : static void
7603 5843 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7604 : unsigned primary, unsigned optional)
7605 : {
7606 5843 : gfc_actual_arglist* prim_arg;
7607 5843 : gfc_actual_arglist* opt_arg;
7608 5843 : unsigned cur_pos;
7609 5843 : gfc_actual_arglist* arg;
7610 5843 : gfc_symbol* sym;
7611 5843 : vec<tree, va_gc> *append_args;
7612 :
7613 : /* Find the two arguments given as position. */
7614 5843 : cur_pos = 0;
7615 5843 : prim_arg = NULL;
7616 5843 : opt_arg = NULL;
7617 17529 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7618 : {
7619 17529 : ++cur_pos;
7620 :
7621 17529 : if (cur_pos == primary)
7622 5843 : prim_arg = arg;
7623 17529 : if (cur_pos == optional)
7624 5843 : opt_arg = arg;
7625 :
7626 17529 : if (cur_pos >= primary && cur_pos >= optional)
7627 : break;
7628 : }
7629 5843 : gcc_assert (prim_arg);
7630 5843 : gcc_assert (prim_arg->expr);
7631 5843 : gcc_assert (opt_arg);
7632 :
7633 : /* If we do have type CHARACTER and the optional argument is really absent,
7634 : append a dummy 0 as string length. */
7635 5843 : append_args = NULL;
7636 5843 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7637 : {
7638 608 : tree dummy;
7639 :
7640 608 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7641 608 : vec_alloc (append_args, 1);
7642 608 : append_args->quick_push (dummy);
7643 : }
7644 :
7645 : /* Build the call itself. */
7646 5843 : gcc_assert (!se->ignore_optional);
7647 5843 : sym = gfc_get_symbol_for_expr (expr, false);
7648 5843 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7649 : append_args);
7650 5843 : gfc_free_symbol (sym);
7651 5843 : }
7652 :
7653 : /* The length of a character string. */
7654 : static void
7655 5861 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7656 : {
7657 5861 : tree len;
7658 5861 : tree type;
7659 5861 : tree decl;
7660 5861 : gfc_symbol *sym;
7661 5861 : gfc_se argse;
7662 5861 : gfc_expr *arg;
7663 :
7664 5861 : gcc_assert (!se->ss);
7665 :
7666 5861 : arg = expr->value.function.actual->expr;
7667 :
7668 5861 : type = gfc_typenode_for_spec (&expr->ts);
7669 5861 : switch (arg->expr_type)
7670 : {
7671 0 : case EXPR_CONSTANT:
7672 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7673 0 : break;
7674 :
7675 2 : case EXPR_ARRAY:
7676 : /* If there is an explicit type-spec, use it. */
7677 2 : if (arg->ts.u.cl->length && arg->ts.u.cl->length_from_typespec)
7678 : {
7679 0 : gfc_conv_string_length (arg->ts.u.cl, arg, &se->pre);
7680 0 : len = arg->ts.u.cl->backend_decl;
7681 0 : break;
7682 : }
7683 :
7684 : /* Obtain the string length from the function used by
7685 : trans-array.cc(gfc_trans_array_constructor). */
7686 2 : len = NULL_TREE;
7687 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7688 2 : break;
7689 :
7690 5274 : case EXPR_VARIABLE:
7691 5274 : if (arg->ref == NULL
7692 2385 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7693 : {
7694 : /* This doesn't catch all cases.
7695 : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7696 : and the surrounding thread. */
7697 4742 : sym = arg->symtree->n.sym;
7698 4742 : decl = gfc_get_symbol_decl (sym);
7699 4742 : if (decl == current_function_decl && sym->attr.function
7700 55 : && (sym->result == sym))
7701 55 : decl = gfc_get_fake_result_decl (sym, 0);
7702 :
7703 4742 : len = sym->ts.u.cl->backend_decl;
7704 4742 : gcc_assert (len);
7705 : break;
7706 : }
7707 :
7708 : /* Fall through. */
7709 :
7710 1117 : default:
7711 1117 : gfc_init_se (&argse, se);
7712 1117 : if (arg->rank == 0)
7713 995 : gfc_conv_expr (&argse, arg);
7714 : else
7715 122 : gfc_conv_expr_descriptor (&argse, arg);
7716 1117 : gfc_add_block_to_block (&se->pre, &argse.pre);
7717 1117 : gfc_add_block_to_block (&se->post, &argse.post);
7718 1117 : len = argse.string_length;
7719 1117 : break;
7720 : }
7721 5861 : se->expr = convert (type, len);
7722 5861 : }
7723 :
7724 : /* The length of a character string not including trailing blanks. */
7725 : static void
7726 2335 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7727 : {
7728 2335 : int kind = expr->value.function.actual->expr->ts.kind;
7729 2335 : tree args[2], type, fndecl;
7730 :
7731 2335 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7732 2335 : type = gfc_typenode_for_spec (&expr->ts);
7733 :
7734 2335 : if (kind == 1)
7735 1933 : fndecl = gfor_fndecl_string_len_trim;
7736 402 : else if (kind == 4)
7737 402 : fndecl = gfor_fndecl_string_len_trim_char4;
7738 : else
7739 0 : gcc_unreachable ();
7740 :
7741 2335 : se->expr = build_call_expr_loc (input_location,
7742 : fndecl, 2, args[0], args[1]);
7743 2335 : se->expr = convert (type, se->expr);
7744 2335 : }
7745 :
7746 :
7747 : /* Returns the starting position of a substring within a string. */
7748 :
7749 : static void
7750 751 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7751 : tree function)
7752 : {
7753 751 : tree logical4_type_node = gfc_get_logical_type (4);
7754 751 : tree type;
7755 751 : tree fndecl;
7756 751 : tree *args;
7757 751 : unsigned int num_args;
7758 :
7759 751 : args = XALLOCAVEC (tree, 5);
7760 :
7761 : /* Get number of arguments; characters count double due to the
7762 : string length argument. Kind= is not passed to the library
7763 : and thus ignored. */
7764 751 : if (expr->value.function.actual->next->next->expr == NULL)
7765 : num_args = 4;
7766 : else
7767 304 : num_args = 5;
7768 :
7769 751 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7770 751 : type = gfc_typenode_for_spec (&expr->ts);
7771 :
7772 751 : if (num_args == 4)
7773 447 : args[4] = build_int_cst (logical4_type_node, 0);
7774 : else
7775 304 : args[4] = convert (logical4_type_node, args[4]);
7776 :
7777 751 : fndecl = build_addr (function);
7778 751 : se->expr = build_call_array_loc (input_location,
7779 751 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7780 : 5, args);
7781 751 : se->expr = convert (type, se->expr);
7782 :
7783 751 : }
7784 :
7785 : /* The ascii value for a single character. */
7786 : static void
7787 2033 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7788 : {
7789 2033 : tree args[3], type, pchartype;
7790 2033 : int nargs;
7791 :
7792 2033 : nargs = gfc_intrinsic_argument_list_length (expr);
7793 2033 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7794 2033 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7795 2033 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7796 2033 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7797 2033 : type = gfc_typenode_for_spec (&expr->ts);
7798 :
7799 2033 : se->expr = build_fold_indirect_ref_loc (input_location,
7800 : args[1]);
7801 2033 : se->expr = convert (type, se->expr);
7802 2033 : }
7803 :
7804 :
7805 : /* Intrinsic ISNAN calls __builtin_isnan. */
7806 :
7807 : static void
7808 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7809 : {
7810 432 : tree arg;
7811 :
7812 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7813 432 : se->expr = build_call_expr_loc (input_location,
7814 : builtin_decl_explicit (BUILT_IN_ISNAN),
7815 : 1, arg);
7816 864 : STRIP_TYPE_NOPS (se->expr);
7817 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7818 432 : }
7819 :
7820 :
7821 : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7822 : their argument against a constant integer value. */
7823 :
7824 : static void
7825 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7826 : {
7827 24 : tree arg;
7828 :
7829 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7830 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7831 : gfc_typenode_for_spec (&expr->ts),
7832 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7833 24 : }
7834 :
7835 :
7836 :
7837 : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7838 :
7839 : static void
7840 949 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7841 : {
7842 949 : tree tsource;
7843 949 : tree fsource;
7844 949 : tree mask;
7845 949 : tree type;
7846 949 : tree len, len2;
7847 949 : tree *args;
7848 949 : unsigned int num_args;
7849 :
7850 949 : num_args = gfc_intrinsic_argument_list_length (expr);
7851 949 : args = XALLOCAVEC (tree, num_args);
7852 :
7853 949 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7854 949 : if (expr->ts.type != BT_CHARACTER)
7855 : {
7856 422 : tsource = args[0];
7857 422 : fsource = args[1];
7858 422 : mask = args[2];
7859 : }
7860 : else
7861 : {
7862 : /* We do the same as in the non-character case, but the argument
7863 : list is different because of the string length arguments. We
7864 : also have to set the string length for the result. */
7865 527 : len = args[0];
7866 527 : tsource = args[1];
7867 527 : len2 = args[2];
7868 527 : fsource = args[3];
7869 527 : mask = args[4];
7870 :
7871 527 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7872 : &se->pre);
7873 527 : se->string_length = len;
7874 : }
7875 949 : tsource = gfc_evaluate_now (tsource, &se->pre);
7876 949 : fsource = gfc_evaluate_now (fsource, &se->pre);
7877 949 : mask = gfc_evaluate_now (mask, &se->pre);
7878 949 : type = TREE_TYPE (tsource);
7879 949 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7880 : fold_convert (type, fsource));
7881 949 : }
7882 :
7883 :
7884 : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7885 :
7886 : static void
7887 42 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7888 : {
7889 42 : tree args[3], mask, type;
7890 :
7891 42 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7892 42 : mask = gfc_evaluate_now (args[2], &se->pre);
7893 :
7894 42 : type = TREE_TYPE (args[0]);
7895 42 : gcc_assert (TREE_TYPE (args[1]) == type);
7896 42 : gcc_assert (TREE_TYPE (mask) == type);
7897 :
7898 42 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7899 42 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7900 : fold_build1_loc (input_location, BIT_NOT_EXPR,
7901 : type, mask));
7902 42 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7903 : args[0], args[1]);
7904 42 : }
7905 :
7906 :
7907 : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7908 : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7909 :
7910 : static void
7911 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7912 : {
7913 64 : tree arg, allones, type, utype, res, cond, bitsize;
7914 64 : int i;
7915 :
7916 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7917 64 : arg = gfc_evaluate_now (arg, &se->pre);
7918 :
7919 64 : type = gfc_get_int_type (expr->ts.kind);
7920 64 : utype = unsigned_type_for (type);
7921 :
7922 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7923 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7924 :
7925 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7926 : build_int_cst (utype, 0));
7927 :
7928 64 : if (left)
7929 : {
7930 : /* Left-justified mask. */
7931 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7932 : bitsize, arg);
7933 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7934 : fold_convert (utype, res));
7935 :
7936 : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7937 : smaller than type width. */
7938 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7939 32 : build_int_cst (TREE_TYPE (arg), 0));
7940 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7941 : build_int_cst (utype, 0), res);
7942 : }
7943 : else
7944 : {
7945 : /* Right-justified mask. */
7946 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7947 : fold_convert (utype, arg));
7948 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7949 :
7950 : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7951 : strictly smaller than type width. */
7952 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7953 : arg, bitsize);
7954 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
7955 : cond, allones, res);
7956 : }
7957 :
7958 64 : se->expr = fold_convert (type, res);
7959 64 : }
7960 :
7961 :
7962 : /* FRACTION (s) is translated into:
7963 : isfinite (s) ? frexp (s, &dummy_int) : NaN */
7964 : static void
7965 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7966 : {
7967 60 : tree arg, type, tmp, res, frexp, cond;
7968 :
7969 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7970 :
7971 60 : type = gfc_typenode_for_spec (&expr->ts);
7972 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7973 60 : arg = gfc_evaluate_now (arg, &se->pre);
7974 :
7975 60 : cond = build_call_expr_loc (input_location,
7976 : builtin_decl_explicit (BUILT_IN_ISFINITE),
7977 : 1, arg);
7978 :
7979 60 : tmp = gfc_create_var (integer_type_node, NULL);
7980 60 : res = build_call_expr_loc (input_location, frexp, 2,
7981 : fold_convert (type, arg),
7982 : gfc_build_addr_expr (NULL_TREE, tmp));
7983 60 : res = fold_convert (type, res);
7984 :
7985 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7986 : cond, res, gfc_build_nan (type, ""));
7987 60 : }
7988 :
7989 :
7990 : /* NEAREST (s, dir) is translated into
7991 : tmp = copysign (HUGE_VAL, dir);
7992 : return nextafter (s, tmp);
7993 : */
7994 : static void
7995 1595 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7996 : {
7997 1595 : tree args[2], type, tmp, nextafter, copysign, huge_val;
7998 :
7999 1595 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
8000 1595 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
8001 :
8002 1595 : type = gfc_typenode_for_spec (&expr->ts);
8003 1595 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8004 :
8005 1595 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
8006 1595 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
8007 : fold_convert (type, args[1]));
8008 1595 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
8009 : fold_convert (type, args[0]), tmp);
8010 1595 : se->expr = fold_convert (type, se->expr);
8011 1595 : }
8012 :
8013 :
8014 : /* SPACING (s) is translated into
8015 : int e;
8016 : if (!isfinite (s))
8017 : res = NaN;
8018 : else if (s == 0)
8019 : res = tiny;
8020 : else
8021 : {
8022 : frexp (s, &e);
8023 : e = e - prec;
8024 : e = MAX_EXPR (e, emin);
8025 : res = scalbn (1., e);
8026 : }
8027 : return res;
8028 :
8029 : where prec is the precision of s, gfc_real_kinds[k].digits,
8030 : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
8031 : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
8032 :
8033 : static void
8034 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8035 : {
8036 70 : tree arg, type, prec, emin, tiny, res, e;
8037 70 : tree cond, nan, tmp, frexp, scalbn;
8038 70 : int k;
8039 70 : stmtblock_t block;
8040 :
8041 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8042 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8043 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8044 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8045 :
8046 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8047 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8048 :
8049 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8050 70 : arg = gfc_evaluate_now (arg, &se->pre);
8051 :
8052 70 : type = gfc_typenode_for_spec (&expr->ts);
8053 70 : e = gfc_create_var (integer_type_node, NULL);
8054 70 : res = gfc_create_var (type, NULL);
8055 :
8056 :
8057 : /* Build the block for s /= 0. */
8058 70 : gfc_start_block (&block);
8059 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8060 : gfc_build_addr_expr (NULL_TREE, e));
8061 70 : gfc_add_expr_to_block (&block, tmp);
8062 :
8063 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8064 : prec);
8065 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8066 : integer_type_node, tmp, emin));
8067 :
8068 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
8069 70 : build_real_from_int_cst (type, integer_one_node), e);
8070 70 : gfc_add_modify (&block, res, tmp);
8071 :
8072 : /* Finish by building the IF statement for value zero. */
8073 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8074 70 : build_real_from_int_cst (type, integer_zero_node));
8075 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8076 : gfc_finish_block (&block));
8077 :
8078 : /* And deal with infinities and NaNs. */
8079 70 : cond = build_call_expr_loc (input_location,
8080 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8081 : 1, arg);
8082 70 : nan = gfc_build_nan (type, "");
8083 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8084 :
8085 70 : gfc_add_expr_to_block (&se->pre, tmp);
8086 70 : se->expr = res;
8087 70 : }
8088 :
8089 :
8090 : /* RRSPACING (s) is translated into
8091 : int e;
8092 : real x;
8093 : x = fabs (s);
8094 : if (isfinite (x))
8095 : {
8096 : if (x != 0)
8097 : {
8098 : frexp (s, &e);
8099 : x = scalbn (x, precision - e);
8100 : }
8101 : }
8102 : else
8103 : x = NaN;
8104 : return x;
8105 :
8106 : where precision is gfc_real_kinds[k].digits. */
8107 :
8108 : static void
8109 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8110 : {
8111 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8112 48 : int prec, k;
8113 48 : stmtblock_t block;
8114 :
8115 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8116 48 : prec = gfc_real_kinds[k].digits;
8117 :
8118 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8119 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8120 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
8121 :
8122 48 : type = gfc_typenode_for_spec (&expr->ts);
8123 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8124 48 : arg = gfc_evaluate_now (arg, &se->pre);
8125 :
8126 48 : e = gfc_create_var (integer_type_node, NULL);
8127 48 : x = gfc_create_var (type, NULL);
8128 48 : gfc_add_modify (&se->pre, x,
8129 : build_call_expr_loc (input_location, fabs, 1, arg));
8130 :
8131 :
8132 48 : gfc_start_block (&block);
8133 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8134 : gfc_build_addr_expr (NULL_TREE, e));
8135 48 : gfc_add_expr_to_block (&block, tmp);
8136 :
8137 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8138 48 : build_int_cst (integer_type_node, prec), e);
8139 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8140 48 : gfc_add_modify (&block, x, tmp);
8141 48 : stmt = gfc_finish_block (&block);
8142 :
8143 : /* if (x != 0) */
8144 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8145 48 : build_real_from_int_cst (type, integer_zero_node));
8146 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8147 :
8148 : /* And deal with infinities and NaNs. */
8149 48 : cond = build_call_expr_loc (input_location,
8150 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8151 : 1, x);
8152 48 : nan = gfc_build_nan (type, "");
8153 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8154 :
8155 48 : gfc_add_expr_to_block (&se->pre, tmp);
8156 48 : se->expr = fold_convert (type, x);
8157 48 : }
8158 :
8159 :
8160 : /* SCALE (s, i) is translated into scalbn (s, i). */
8161 : static void
8162 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8163 : {
8164 72 : tree args[2], type, scalbn;
8165 :
8166 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8167 :
8168 72 : type = gfc_typenode_for_spec (&expr->ts);
8169 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8170 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
8171 : fold_convert (type, args[0]),
8172 : fold_convert (integer_type_node, args[1]));
8173 72 : se->expr = fold_convert (type, se->expr);
8174 72 : }
8175 :
8176 :
8177 : /* SET_EXPONENT (s, i) is translated into
8178 : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8179 : static void
8180 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8181 : {
8182 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8183 :
8184 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8185 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8186 :
8187 262 : type = gfc_typenode_for_spec (&expr->ts);
8188 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8189 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
8190 :
8191 262 : tmp = gfc_create_var (integer_type_node, NULL);
8192 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
8193 : fold_convert (type, args[0]),
8194 : gfc_build_addr_expr (NULL_TREE, tmp));
8195 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8196 : fold_convert (integer_type_node, args[1]));
8197 262 : res = fold_convert (type, res);
8198 :
8199 : /* Call to isfinite */
8200 262 : cond = build_call_expr_loc (input_location,
8201 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8202 : 1, args[0]);
8203 262 : nan = gfc_build_nan (type, "");
8204 :
8205 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8206 : res, nan);
8207 262 : }
8208 :
8209 :
8210 : static void
8211 15306 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8212 : {
8213 15306 : gfc_actual_arglist *actual;
8214 15306 : tree arg1;
8215 15306 : tree type;
8216 15306 : tree size;
8217 15306 : gfc_se argse;
8218 15306 : gfc_expr *e;
8219 15306 : gfc_symbol *sym = NULL;
8220 :
8221 15306 : gfc_init_se (&argse, NULL);
8222 15306 : actual = expr->value.function.actual;
8223 :
8224 15306 : if (actual->expr->ts.type == BT_CLASS)
8225 627 : gfc_add_class_array_ref (actual->expr);
8226 :
8227 15306 : e = actual->expr;
8228 :
8229 : /* These are emerging from the interface mapping, when a class valued
8230 : function appears as the rhs in a realloc on assign statement, where
8231 : the size of the result is that of one of the actual arguments. */
8232 15306 : if (e->expr_type == EXPR_VARIABLE
8233 14830 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8234 573 : && e->symtree->n.sym->ts.type == BT_CLASS
8235 62 : && e->ref && e->ref->type == REF_COMPONENT
8236 44 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8237 15306 : sym = e->symtree->n.sym;
8238 :
8239 15306 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8240 : && e
8241 854 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8242 : {
8243 854 : symbol_attribute attr;
8244 854 : char *msg;
8245 854 : tree temp;
8246 854 : tree cond;
8247 :
8248 854 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8249 : {
8250 33 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
8251 33 : attr.pointer = attr.class_pointer;
8252 : }
8253 : else
8254 821 : attr = gfc_expr_attr (e);
8255 :
8256 854 : if (attr.allocatable)
8257 100 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
8258 100 : e->symtree->n.sym->name);
8259 754 : else if (attr.pointer)
8260 46 : msg = xasprintf ("Pointer argument '%s' is not associated",
8261 46 : e->symtree->n.sym->name);
8262 : else
8263 708 : goto end_arg_check;
8264 :
8265 146 : if (sym)
8266 : {
8267 0 : temp = gfc_class_data_get (sym->backend_decl);
8268 0 : temp = gfc_conv_descriptor_data_get (temp);
8269 : }
8270 : else
8271 : {
8272 146 : argse.descriptor_only = 1;
8273 146 : gfc_conv_expr_descriptor (&argse, actual->expr);
8274 146 : temp = gfc_conv_descriptor_data_get (argse.expr);
8275 : }
8276 :
8277 146 : cond = fold_build2_loc (input_location, EQ_EXPR,
8278 : logical_type_node, temp,
8279 146 : fold_convert (TREE_TYPE (temp),
8280 : null_pointer_node));
8281 146 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8282 :
8283 146 : free (msg);
8284 : }
8285 14452 : end_arg_check:
8286 :
8287 15306 : argse.data_not_needed = 1;
8288 15306 : if (gfc_is_class_array_function (e))
8289 : {
8290 : /* For functions that return a class array conv_expr_descriptor is not
8291 : able to get the descriptor right. Therefore this special case. */
8292 7 : gfc_conv_expr_reference (&argse, e);
8293 7 : argse.expr = gfc_class_data_get (argse.expr);
8294 : }
8295 15299 : else if (sym && sym->backend_decl)
8296 : {
8297 32 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8298 32 : argse.expr = gfc_class_data_get (sym->backend_decl);
8299 : }
8300 : else
8301 15267 : gfc_conv_expr_descriptor (&argse, actual->expr);
8302 15306 : gfc_add_block_to_block (&se->pre, &argse.pre);
8303 15306 : gfc_add_block_to_block (&se->post, &argse.post);
8304 15306 : arg1 = argse.expr;
8305 :
8306 15306 : actual = actual->next;
8307 15306 : if (actual->expr)
8308 : {
8309 9126 : stmtblock_t block;
8310 9126 : gfc_init_block (&block);
8311 9126 : gfc_init_se (&argse, NULL);
8312 9126 : gfc_conv_expr_type (&argse, actual->expr,
8313 : gfc_array_index_type);
8314 9126 : gfc_add_block_to_block (&block, &argse.pre);
8315 9126 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8316 : argse.expr, gfc_index_one_node);
8317 9126 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8318 :
8319 : /* Unusually, for an intrinsic, size does not exclude
8320 : an optional arg2, so we must test for it. */
8321 9126 : if (actual->expr->expr_type == EXPR_VARIABLE
8322 2444 : && actual->expr->symtree->n.sym->attr.dummy
8323 31 : && actual->expr->symtree->n.sym->attr.optional)
8324 : {
8325 31 : tree cond;
8326 31 : stmtblock_t block2;
8327 31 : gfc_init_block (&block2);
8328 31 : gfc_init_se (&argse, NULL);
8329 31 : argse.want_pointer = 1;
8330 31 : argse.data_not_needed = 1;
8331 31 : gfc_conv_expr (&argse, actual->expr);
8332 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8333 : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8334 : case; size_var can be used in both blocks. */
8335 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8336 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8337 31 : TREE_TYPE (size_var), size_var, size);
8338 31 : gfc_add_expr_to_block (&block, tmp);
8339 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8340 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8341 31 : TREE_TYPE (size_var), size_var, size);
8342 31 : gfc_add_expr_to_block (&block2, tmp);
8343 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8344 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8345 : gfc_finish_block (&block2));
8346 31 : gfc_add_expr_to_block (&se->pre, tmp);
8347 31 : size = size_var;
8348 31 : }
8349 : else
8350 9095 : gfc_add_block_to_block (&se->pre, &block);
8351 : }
8352 : else
8353 6180 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8354 15306 : type = gfc_typenode_for_spec (&expr->ts);
8355 15306 : se->expr = convert (type, size);
8356 15306 : }
8357 :
8358 :
8359 : /* Helper function to compute the size of a character variable,
8360 : excluding the terminating null characters. The result has
8361 : gfc_array_index_type type. */
8362 :
8363 : tree
8364 1864 : size_of_string_in_bytes (int kind, tree string_length)
8365 : {
8366 1864 : tree bytesize;
8367 1864 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8368 :
8369 3728 : bytesize = build_int_cst (gfc_array_index_type,
8370 1864 : gfc_character_kinds[i].bit_size / 8);
8371 :
8372 1864 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8373 : bytesize,
8374 1864 : fold_convert (gfc_array_index_type, string_length));
8375 : }
8376 :
8377 :
8378 : static void
8379 1309 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8380 : {
8381 1309 : gfc_expr *arg;
8382 1309 : gfc_se argse;
8383 1309 : tree source_bytes;
8384 1309 : tree tmp;
8385 1309 : tree lower;
8386 1309 : tree upper;
8387 1309 : tree byte_size;
8388 1309 : tree field;
8389 1309 : int n;
8390 :
8391 1309 : gfc_init_se (&argse, NULL);
8392 1309 : arg = expr->value.function.actual->expr;
8393 :
8394 1309 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8395 1012 : gfc_conv_expr_descriptor (&argse, arg);
8396 : else
8397 297 : gfc_conv_expr_reference (&argse, arg);
8398 :
8399 1309 : if (arg->ts.type == BT_ASSUMED)
8400 : {
8401 : /* This only works if an array descriptor has been passed; thus, extract
8402 : the size from the descriptor. */
8403 172 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8404 : == TYPE_PRECISION (size_type_node));
8405 172 : tmp = arg->symtree->n.sym->backend_decl;
8406 172 : tmp = DECL_LANG_SPECIFIC (tmp)
8407 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8408 226 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8409 172 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8410 172 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8411 :
8412 172 : tmp = gfc_conv_descriptor_dtype (tmp);
8413 172 : field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8414 : GFC_DTYPE_ELEM_LEN);
8415 172 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8416 : tmp, field, NULL_TREE);
8417 :
8418 172 : byte_size = fold_convert (gfc_array_index_type, tmp);
8419 : }
8420 1137 : else if (arg->ts.type == BT_CLASS)
8421 : {
8422 : /* Conv_expr_descriptor returns a component_ref to _data component of the
8423 : class object. The class object may be a non-pointer object, e.g.
8424 : located on the stack, or a memory location pointed to, e.g. a
8425 : parameter, i.e., an indirect_ref. */
8426 959 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8427 589 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8428 198 : byte_size
8429 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8430 391 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8431 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8432 391 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8433 391 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8434 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8435 63 : else if (arg->rank > 0
8436 21 : || (arg->rank == 0
8437 21 : && arg->ref && arg->ref->type == REF_COMPONENT))
8438 : {
8439 : /* The scalarizer added an additional temp. To get the class' vptr
8440 : one has to look at the original backend_decl. */
8441 63 : if (argse.class_container)
8442 21 : byte_size = gfc_class_vtab_size_get (argse.class_container);
8443 42 : else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8444 84 : byte_size = gfc_class_vtab_size_get (
8445 42 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8446 : else
8447 0 : gcc_unreachable ();
8448 : }
8449 : else
8450 0 : gcc_unreachable ();
8451 : }
8452 : else
8453 : {
8454 548 : if (arg->ts.type == BT_CHARACTER)
8455 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8456 : else
8457 : {
8458 464 : if (arg->rank == 0)
8459 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8460 : argse.expr));
8461 : else
8462 464 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8463 464 : byte_size = fold_convert (gfc_array_index_type,
8464 : size_in_bytes (byte_size));
8465 : }
8466 : }
8467 :
8468 1309 : if (arg->rank == 0)
8469 297 : se->expr = byte_size;
8470 : else
8471 : {
8472 1012 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8473 1012 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8474 :
8475 1012 : if (arg->rank == -1)
8476 : {
8477 365 : tree cond, loop_var, exit_label;
8478 365 : stmtblock_t body;
8479 :
8480 365 : tmp = fold_convert (gfc_array_index_type,
8481 : gfc_conv_descriptor_rank (argse.expr));
8482 365 : loop_var = gfc_create_var (gfc_array_index_type, "i");
8483 365 : gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8484 365 : exit_label = gfc_build_label_decl (NULL_TREE);
8485 :
8486 : /* Create loop:
8487 : for (;;)
8488 : {
8489 : if (i >= rank)
8490 : goto exit;
8491 : source_bytes = source_bytes * array.dim[i].extent;
8492 : i = i + 1;
8493 : }
8494 : exit: */
8495 365 : gfc_start_block (&body);
8496 365 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8497 : loop_var, tmp);
8498 365 : tmp = build1_v (GOTO_EXPR, exit_label);
8499 365 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8500 : cond, tmp, build_empty_stmt (input_location));
8501 365 : gfc_add_expr_to_block (&body, tmp);
8502 :
8503 365 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8504 365 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8505 365 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8506 365 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8507 : gfc_array_index_type, tmp, source_bytes);
8508 365 : gfc_add_modify (&body, source_bytes, tmp);
8509 :
8510 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8511 : gfc_array_index_type, loop_var,
8512 : gfc_index_one_node);
8513 365 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8514 :
8515 365 : tmp = gfc_finish_block (&body);
8516 :
8517 365 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8518 : tmp);
8519 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8520 :
8521 365 : tmp = build1_v (LABEL_EXPR, exit_label);
8522 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8523 : }
8524 : else
8525 : {
8526 : /* Obtain the size of the array in bytes. */
8527 1834 : for (n = 0; n < arg->rank; n++)
8528 : {
8529 1187 : tree idx;
8530 1187 : idx = gfc_rank_cst[n];
8531 1187 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8532 1187 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8533 1187 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8534 1187 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8535 : gfc_array_index_type, tmp, source_bytes);
8536 1187 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8537 : }
8538 : }
8539 1012 : se->expr = source_bytes;
8540 : }
8541 :
8542 1309 : gfc_add_block_to_block (&se->pre, &argse.pre);
8543 1309 : }
8544 :
8545 :
8546 : static void
8547 840 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8548 : {
8549 840 : gfc_expr *arg;
8550 840 : gfc_se argse;
8551 840 : tree type, result_type, tmp, class_decl = NULL;
8552 840 : gfc_symbol *sym;
8553 840 : bool unlimited = false;
8554 :
8555 840 : arg = expr->value.function.actual->expr;
8556 :
8557 840 : gfc_init_se (&argse, NULL);
8558 840 : result_type = gfc_get_int_type (expr->ts.kind);
8559 :
8560 840 : if (arg->rank == 0)
8561 : {
8562 230 : if (arg->ts.type == BT_CLASS)
8563 : {
8564 86 : unlimited = UNLIMITED_POLY (arg);
8565 86 : gfc_add_vptr_component (arg);
8566 86 : gfc_add_size_component (arg);
8567 86 : gfc_conv_expr (&argse, arg);
8568 86 : tmp = fold_convert (result_type, argse.expr);
8569 86 : class_decl = gfc_get_class_from_expr (argse.expr);
8570 86 : goto done;
8571 : }
8572 :
8573 144 : gfc_conv_expr_reference (&argse, arg);
8574 144 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8575 : argse.expr));
8576 : }
8577 : else
8578 : {
8579 610 : argse.want_pointer = 0;
8580 610 : gfc_conv_expr_descriptor (&argse, arg);
8581 610 : sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8582 610 : if (arg->ts.type == BT_CLASS)
8583 : {
8584 60 : unlimited = UNLIMITED_POLY (arg);
8585 60 : if (TREE_CODE (argse.expr) == COMPONENT_REF)
8586 54 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8587 6 : else if (arg->rank > 0 && sym
8588 12 : && DECL_LANG_SPECIFIC (sym->backend_decl))
8589 12 : tmp = gfc_class_vtab_size_get (
8590 6 : GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8591 : else
8592 0 : gcc_unreachable ();
8593 60 : tmp = fold_convert (result_type, tmp);
8594 60 : class_decl = gfc_get_class_from_expr (argse.expr);
8595 60 : goto done;
8596 : }
8597 550 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8598 : }
8599 :
8600 : /* Obtain the argument's word length. */
8601 694 : if (arg->ts.type == BT_CHARACTER)
8602 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8603 : else
8604 453 : tmp = size_in_bytes (type);
8605 694 : tmp = fold_convert (result_type, tmp);
8606 :
8607 840 : done:
8608 840 : if (unlimited && class_decl)
8609 68 : tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8610 :
8611 840 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8612 : build_int_cst (result_type, BITS_PER_UNIT));
8613 840 : gfc_add_block_to_block (&se->pre, &argse.pre);
8614 840 : }
8615 :
8616 :
8617 : /* Intrinsic string comparison functions. */
8618 :
8619 : static void
8620 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8621 : {
8622 99 : tree args[4];
8623 :
8624 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8625 :
8626 99 : se->expr
8627 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8628 99 : expr->value.function.actual->expr->ts.kind,
8629 : op);
8630 99 : se->expr = fold_build2_loc (input_location, op,
8631 : gfc_typenode_for_spec (&expr->ts), se->expr,
8632 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8633 99 : }
8634 :
8635 : /* Generate a call to the adjustl/adjustr library function. */
8636 : static void
8637 468 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8638 : {
8639 468 : tree args[3];
8640 468 : tree len;
8641 468 : tree type;
8642 468 : tree var;
8643 468 : tree tmp;
8644 :
8645 468 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8646 468 : len = args[1];
8647 :
8648 468 : type = TREE_TYPE (args[2]);
8649 468 : var = gfc_conv_string_tmp (se, type, len);
8650 468 : args[0] = var;
8651 :
8652 468 : tmp = build_call_expr_loc (input_location,
8653 : fndecl, 3, args[0], args[1], args[2]);
8654 468 : gfc_add_expr_to_block (&se->pre, tmp);
8655 468 : se->expr = var;
8656 468 : se->string_length = len;
8657 468 : }
8658 :
8659 :
8660 : /* Generate code for the TRANSFER intrinsic:
8661 : For scalar results:
8662 : DEST = TRANSFER (SOURCE, MOLD)
8663 : where:
8664 : typeof<DEST> = typeof<MOLD>
8665 : and:
8666 : MOLD is scalar.
8667 :
8668 : For array results:
8669 : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8670 : where:
8671 : typeof<DEST> = typeof<MOLD>
8672 : and:
8673 : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8674 : sizeof (DEST(0) * SIZE). */
8675 : static void
8676 3824 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8677 : {
8678 3824 : tree tmp;
8679 3824 : tree tmpdecl;
8680 3824 : tree ptr;
8681 3824 : tree extent;
8682 3824 : tree source;
8683 3824 : tree source_type;
8684 3824 : tree source_bytes;
8685 3824 : tree mold_type;
8686 3824 : tree dest_word_len;
8687 3824 : tree size_words;
8688 3824 : tree size_bytes;
8689 3824 : tree upper;
8690 3824 : tree lower;
8691 3824 : tree stmt;
8692 3824 : tree class_ref = NULL_TREE;
8693 3824 : gfc_actual_arglist *arg;
8694 3824 : gfc_se argse;
8695 3824 : gfc_array_info *info;
8696 3824 : stmtblock_t block;
8697 3824 : int n;
8698 3824 : bool scalar_mold;
8699 3824 : gfc_expr *source_expr, *mold_expr, *class_expr;
8700 :
8701 3824 : info = NULL;
8702 3824 : if (se->loop)
8703 472 : info = &se->ss->info->data.array;
8704 :
8705 : /* Convert SOURCE. The output from this stage is:-
8706 : source_bytes = length of the source in bytes
8707 : source = pointer to the source data. */
8708 3824 : arg = expr->value.function.actual;
8709 3824 : source_expr = arg->expr;
8710 :
8711 : /* Ensure double transfer through LOGICAL preserves all
8712 : the needed bits. */
8713 3824 : if (arg->expr->expr_type == EXPR_FUNCTION
8714 2832 : && arg->expr->value.function.esym == NULL
8715 2808 : && arg->expr->value.function.isym != NULL
8716 2808 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8717 12 : && arg->expr->ts.type == BT_LOGICAL
8718 12 : && expr->ts.type != arg->expr->ts.type)
8719 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8720 :
8721 3824 : gfc_init_se (&argse, NULL);
8722 :
8723 3824 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8724 :
8725 : /* Obtain the pointer to source and the length of source in bytes. */
8726 3824 : if (arg->expr->rank == 0)
8727 : {
8728 3468 : gfc_conv_expr_reference (&argse, arg->expr);
8729 3468 : if (arg->expr->ts.type == BT_CLASS)
8730 : {
8731 37 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8732 37 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8733 : {
8734 19 : source = gfc_class_data_get (tmp);
8735 19 : class_ref = tmp;
8736 : }
8737 : else
8738 : {
8739 : /* Array elements are evaluated as a reference to the data.
8740 : To obtain the vptr for the element size, the argument
8741 : expression must be stripped to the class reference and
8742 : re-evaluated. The pre and post blocks are not needed. */
8743 18 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8744 18 : source = argse.expr;
8745 18 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8746 18 : gfc_init_se (&argse, NULL);
8747 18 : gfc_conv_expr (&argse, class_expr);
8748 18 : class_ref = argse.expr;
8749 : }
8750 : }
8751 : else
8752 3431 : source = argse.expr;
8753 :
8754 : /* Obtain the source word length. */
8755 3468 : switch (arg->expr->ts.type)
8756 : {
8757 294 : case BT_CHARACTER:
8758 294 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8759 : argse.string_length);
8760 294 : break;
8761 37 : case BT_CLASS:
8762 37 : if (class_ref != NULL_TREE)
8763 : {
8764 37 : tmp = gfc_class_vtab_size_get (class_ref);
8765 37 : if (UNLIMITED_POLY (source_expr))
8766 30 : tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8767 : }
8768 : else
8769 : {
8770 0 : tmp = gfc_class_vtab_size_get (argse.expr);
8771 0 : if (UNLIMITED_POLY (source_expr))
8772 0 : tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8773 : }
8774 : break;
8775 3137 : default:
8776 3137 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8777 : source));
8778 3137 : tmp = fold_convert (gfc_array_index_type,
8779 : size_in_bytes (source_type));
8780 3137 : break;
8781 : }
8782 : }
8783 : else
8784 : {
8785 356 : bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8786 : false, true);
8787 356 : argse.want_pointer = 0;
8788 : /* A non-contiguous SOURCE needs packing. */
8789 356 : if (!simply_contiguous)
8790 74 : argse.force_tmp = 1;
8791 356 : gfc_conv_expr_descriptor (&argse, arg->expr);
8792 356 : source = gfc_conv_descriptor_data_get (argse.expr);
8793 356 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8794 :
8795 : /* Repack the source if not simply contiguous. */
8796 356 : if (!simply_contiguous)
8797 : {
8798 74 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8799 :
8800 74 : if (warn_array_temporaries)
8801 0 : gfc_warning (OPT_Warray_temporaries,
8802 : "Creating array temporary at %L", &expr->where);
8803 :
8804 74 : source = build_call_expr_loc (input_location,
8805 : gfor_fndecl_in_pack, 1, tmp);
8806 74 : source = gfc_evaluate_now (source, &argse.pre);
8807 :
8808 : /* Free the temporary. */
8809 74 : gfc_start_block (&block);
8810 74 : tmp = gfc_call_free (source);
8811 74 : gfc_add_expr_to_block (&block, tmp);
8812 74 : stmt = gfc_finish_block (&block);
8813 :
8814 : /* Clean up if it was repacked. */
8815 74 : gfc_init_block (&block);
8816 74 : tmp = gfc_conv_array_data (argse.expr);
8817 74 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8818 : source, tmp);
8819 74 : tmp = build3_v (COND_EXPR, tmp, stmt,
8820 : build_empty_stmt (input_location));
8821 74 : gfc_add_expr_to_block (&block, tmp);
8822 74 : gfc_add_block_to_block (&block, &se->post);
8823 74 : gfc_init_block (&se->post);
8824 74 : gfc_add_block_to_block (&se->post, &block);
8825 : }
8826 :
8827 : /* Obtain the source word length. */
8828 356 : if (arg->expr->ts.type == BT_CHARACTER)
8829 144 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8830 : argse.string_length);
8831 212 : else if (arg->expr->ts.type == BT_CLASS)
8832 : {
8833 54 : if (UNLIMITED_POLY (source_expr)
8834 54 : && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8835 12 : class_ref = GFC_DECL_SAVED_DESCRIPTOR
8836 : (source_expr->symtree->n.sym->backend_decl);
8837 : else
8838 42 : class_ref = TREE_OPERAND (argse.expr, 0);
8839 54 : tmp = gfc_class_vtab_size_get (class_ref);
8840 54 : if (UNLIMITED_POLY (arg->expr))
8841 54 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8842 : }
8843 : else
8844 158 : tmp = fold_convert (gfc_array_index_type,
8845 : size_in_bytes (source_type));
8846 :
8847 : /* Obtain the size of the array in bytes. */
8848 356 : extent = gfc_create_var (gfc_array_index_type, NULL);
8849 742 : for (n = 0; n < arg->expr->rank; n++)
8850 : {
8851 386 : tree idx;
8852 386 : idx = gfc_rank_cst[n];
8853 386 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8854 386 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8855 386 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8856 386 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8857 : gfc_array_index_type, upper, lower);
8858 386 : gfc_add_modify (&argse.pre, extent, tmp);
8859 386 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8860 : gfc_array_index_type, extent,
8861 : gfc_index_one_node);
8862 386 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8863 : gfc_array_index_type, tmp, source_bytes);
8864 : }
8865 : }
8866 :
8867 3824 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8868 3824 : gfc_add_block_to_block (&se->pre, &argse.pre);
8869 3824 : gfc_add_block_to_block (&se->post, &argse.post);
8870 :
8871 : /* Now convert MOLD. The outputs are:
8872 : mold_type = the TREE type of MOLD
8873 : dest_word_len = destination word length in bytes. */
8874 3824 : arg = arg->next;
8875 3824 : mold_expr = arg->expr;
8876 :
8877 3824 : gfc_init_se (&argse, NULL);
8878 :
8879 3824 : scalar_mold = arg->expr->rank == 0;
8880 :
8881 3824 : if (arg->expr->rank == 0)
8882 : {
8883 3501 : gfc_conv_expr_reference (&argse, mold_expr);
8884 3501 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8885 : argse.expr));
8886 : }
8887 : else
8888 : {
8889 323 : argse.want_pointer = 0;
8890 323 : gfc_conv_expr_descriptor (&argse, mold_expr);
8891 323 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8892 : }
8893 :
8894 3824 : gfc_add_block_to_block (&se->pre, &argse.pre);
8895 3824 : gfc_add_block_to_block (&se->post, &argse.post);
8896 :
8897 3824 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8898 : {
8899 : /* If this TRANSFER is nested in another TRANSFER, use a type
8900 : that preserves all bits. */
8901 12 : if (mold_expr->ts.type == BT_LOGICAL)
8902 12 : mold_type = gfc_get_int_type (mold_expr->ts.kind);
8903 : }
8904 :
8905 : /* Obtain the destination word length. */
8906 3824 : switch (mold_expr->ts.type)
8907 : {
8908 467 : case BT_CHARACTER:
8909 467 : tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
8910 467 : mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8911 : argse.string_length);
8912 467 : break;
8913 6 : case BT_CLASS:
8914 6 : if (scalar_mold)
8915 6 : class_ref = argse.expr;
8916 : else
8917 0 : class_ref = TREE_OPERAND (argse.expr, 0);
8918 6 : tmp = gfc_class_vtab_size_get (class_ref);
8919 6 : if (UNLIMITED_POLY (arg->expr))
8920 0 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8921 : break;
8922 3351 : default:
8923 3351 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8924 3351 : break;
8925 : }
8926 :
8927 : /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8928 : up being used before the assignment. */
8929 3824 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8930 : dest_word_len = tmp;
8931 : else
8932 : {
8933 3770 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8934 3770 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8935 : }
8936 :
8937 : /* Finally convert SIZE, if it is present. */
8938 3824 : arg = arg->next;
8939 3824 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8940 :
8941 3824 : if (arg->expr)
8942 : {
8943 222 : gfc_init_se (&argse, NULL);
8944 222 : gfc_conv_expr_reference (&argse, arg->expr);
8945 222 : tmp = convert (gfc_array_index_type,
8946 : build_fold_indirect_ref_loc (input_location,
8947 : argse.expr));
8948 222 : gfc_add_block_to_block (&se->pre, &argse.pre);
8949 222 : gfc_add_block_to_block (&se->post, &argse.post);
8950 : }
8951 : else
8952 : tmp = NULL_TREE;
8953 :
8954 : /* Separate array and scalar results. */
8955 3824 : if (scalar_mold && tmp == NULL_TREE)
8956 3352 : goto scalar_transfer;
8957 :
8958 472 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8959 472 : if (tmp != NULL_TREE)
8960 222 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8961 : tmp, dest_word_len);
8962 : else
8963 : tmp = source_bytes;
8964 :
8965 472 : gfc_add_modify (&se->pre, size_bytes, tmp);
8966 472 : gfc_add_modify (&se->pre, size_words,
8967 : fold_build2_loc (input_location, CEIL_DIV_EXPR,
8968 : gfc_array_index_type,
8969 : size_bytes, dest_word_len));
8970 :
8971 : /* Evaluate the bounds of the result. If the loop range exists, we have
8972 : to check if it is too large. If so, we modify loop->to be consistent
8973 : with min(size, size(source)). Otherwise, size is made consistent with
8974 : the loop range, so that the right number of bytes is transferred.*/
8975 472 : n = se->loop->order[0];
8976 472 : if (se->loop->to[n] != NULL_TREE)
8977 : {
8978 205 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8979 : se->loop->to[n], se->loop->from[n]);
8980 205 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8981 : tmp, gfc_index_one_node);
8982 205 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8983 : tmp, size_words);
8984 205 : gfc_add_modify (&se->pre, size_words, tmp);
8985 205 : gfc_add_modify (&se->pre, size_bytes,
8986 : fold_build2_loc (input_location, MULT_EXPR,
8987 : gfc_array_index_type,
8988 : size_words, dest_word_len));
8989 410 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8990 205 : size_words, se->loop->from[n]);
8991 205 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8992 : upper, gfc_index_one_node);
8993 : }
8994 : else
8995 : {
8996 267 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8997 : size_words, gfc_index_one_node);
8998 267 : se->loop->from[n] = gfc_index_zero_node;
8999 : }
9000 :
9001 472 : se->loop->to[n] = upper;
9002 :
9003 : /* Build a destination descriptor, using the pointer, source, as the
9004 : data field. */
9005 472 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
9006 : NULL_TREE, false, true, false, &expr->where);
9007 :
9008 : /* Cast the pointer to the result. */
9009 472 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9010 472 : tmp = fold_convert (pvoid_type_node, tmp);
9011 :
9012 : /* Use memcpy to do the transfer. */
9013 472 : tmp
9014 472 : = build_call_expr_loc (input_location,
9015 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
9016 : fold_convert (pvoid_type_node, source),
9017 : fold_convert (size_type_node,
9018 : fold_build2_loc (input_location,
9019 : MIN_EXPR,
9020 : gfc_array_index_type,
9021 : size_bytes,
9022 : source_bytes)));
9023 472 : gfc_add_expr_to_block (&se->pre, tmp);
9024 :
9025 472 : se->expr = info->descriptor;
9026 472 : if (expr->ts.type == BT_CHARACTER)
9027 : {
9028 275 : tmp = fold_convert (gfc_charlen_type_node,
9029 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9030 275 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9031 : gfc_charlen_type_node,
9032 : dest_word_len, tmp);
9033 : }
9034 :
9035 472 : return;
9036 :
9037 : /* Deal with scalar results. */
9038 3352 : scalar_transfer:
9039 3352 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9040 : dest_word_len, source_bytes);
9041 3352 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9042 : extent, gfc_index_zero_node);
9043 :
9044 3352 : if (expr->ts.type == BT_CHARACTER)
9045 : {
9046 192 : tree direct, indirect, free;
9047 :
9048 192 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9049 192 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9050 : "transfer");
9051 :
9052 : /* If source is longer than the destination, use a pointer to
9053 : the source directly. */
9054 192 : gfc_init_block (&block);
9055 192 : gfc_add_modify (&block, tmpdecl, ptr);
9056 192 : direct = gfc_finish_block (&block);
9057 :
9058 : /* Otherwise, allocate a string with the length of the destination
9059 : and copy the source into it. */
9060 192 : gfc_init_block (&block);
9061 192 : tmp = gfc_get_pchar_type (expr->ts.kind);
9062 192 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9063 192 : gfc_add_modify (&block, tmpdecl,
9064 192 : fold_convert (TREE_TYPE (ptr), tmp));
9065 192 : tmp = build_call_expr_loc (input_location,
9066 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9067 : fold_convert (pvoid_type_node, tmpdecl),
9068 : fold_convert (pvoid_type_node, ptr),
9069 : fold_convert (size_type_node, extent));
9070 192 : gfc_add_expr_to_block (&block, tmp);
9071 192 : indirect = gfc_finish_block (&block);
9072 :
9073 : /* Wrap it up with the condition. */
9074 192 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9075 : dest_word_len, source_bytes);
9076 192 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9077 192 : gfc_add_expr_to_block (&se->pre, tmp);
9078 :
9079 : /* Free the temporary string, if necessary. */
9080 192 : free = gfc_call_free (tmpdecl);
9081 192 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9082 : dest_word_len, source_bytes);
9083 192 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9084 192 : gfc_add_expr_to_block (&se->post, tmp);
9085 :
9086 192 : se->expr = tmpdecl;
9087 192 : tmp = fold_convert (gfc_charlen_type_node,
9088 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9089 192 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9090 : gfc_charlen_type_node,
9091 : dest_word_len, tmp);
9092 : }
9093 : else
9094 : {
9095 3160 : tmpdecl = gfc_create_var (mold_type, "transfer");
9096 :
9097 3160 : ptr = convert (build_pointer_type (mold_type), source);
9098 :
9099 : /* For CLASS results, allocate the needed memory first. */
9100 3160 : if (mold_expr->ts.type == BT_CLASS)
9101 : {
9102 6 : tree cdata;
9103 6 : cdata = gfc_class_data_get (tmpdecl);
9104 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9105 6 : gfc_add_modify (&se->pre, cdata, tmp);
9106 : }
9107 :
9108 : /* Use memcpy to do the transfer. */
9109 3160 : if (mold_expr->ts.type == BT_CLASS)
9110 6 : tmp = gfc_class_data_get (tmpdecl);
9111 : else
9112 3154 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9113 :
9114 3160 : tmp = build_call_expr_loc (input_location,
9115 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9116 : fold_convert (pvoid_type_node, tmp),
9117 : fold_convert (pvoid_type_node, ptr),
9118 : fold_convert (size_type_node, extent));
9119 3160 : gfc_add_expr_to_block (&se->pre, tmp);
9120 :
9121 : /* For CLASS results, set the _vptr. */
9122 3160 : if (mold_expr->ts.type == BT_CLASS)
9123 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9124 :
9125 3160 : se->expr = tmpdecl;
9126 : }
9127 : }
9128 :
9129 :
9130 : /* Generate code for the ALLOCATED intrinsic.
9131 : Generate inline code that directly check the address of the argument. */
9132 :
9133 : static void
9134 7381 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9135 : {
9136 7381 : gfc_se arg1se;
9137 7381 : tree tmp;
9138 7381 : gfc_expr *e = expr->value.function.actual->expr;
9139 :
9140 7381 : gfc_init_se (&arg1se, NULL);
9141 7381 : if (e->ts.type == BT_CLASS)
9142 : {
9143 : /* Make sure that class array expressions have both a _data
9144 : component reference and an array reference.... */
9145 899 : if (CLASS_DATA (e)->attr.dimension)
9146 418 : gfc_add_class_array_ref (e);
9147 : /* .... whilst scalars only need the _data component. */
9148 : else
9149 481 : gfc_add_data_component (e);
9150 : }
9151 :
9152 7381 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9153 :
9154 7381 : if (e->rank == 0)
9155 : {
9156 : /* Allocatable scalar. */
9157 2876 : arg1se.want_pointer = 1;
9158 2876 : gfc_conv_expr (&arg1se, e);
9159 2876 : tmp = arg1se.expr;
9160 : }
9161 : else
9162 : {
9163 : /* Allocatable array. */
9164 4505 : arg1se.descriptor_only = 1;
9165 4505 : gfc_conv_expr_descriptor (&arg1se, e);
9166 4505 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9167 : }
9168 :
9169 7381 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9170 7381 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9171 :
9172 : /* Components of pointer array references sometimes come back with a pre block. */
9173 7381 : if (arg1se.pre.head)
9174 327 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9175 :
9176 7381 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9177 7381 : }
9178 :
9179 :
9180 : /* Generate code for the ASSOCIATED intrinsic.
9181 : If both POINTER and TARGET are arrays, generate a call to library function
9182 : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9183 : In other cases, generate inline code that directly compare the address of
9184 : POINTER with the address of TARGET. */
9185 :
9186 : static void
9187 9514 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9188 : {
9189 9514 : gfc_actual_arglist *arg1;
9190 9514 : gfc_actual_arglist *arg2;
9191 9514 : gfc_se arg1se;
9192 9514 : gfc_se arg2se;
9193 9514 : tree tmp2;
9194 9514 : tree tmp;
9195 9514 : tree nonzero_arraylen = NULL_TREE;
9196 9514 : gfc_ss *ss;
9197 9514 : bool scalar;
9198 :
9199 9514 : gfc_init_se (&arg1se, NULL);
9200 9514 : gfc_init_se (&arg2se, NULL);
9201 9514 : arg1 = expr->value.function.actual;
9202 9514 : arg2 = arg1->next;
9203 :
9204 : /* Check whether the expression is a scalar or not; we cannot use
9205 : arg1->expr->rank as it can be nonzero for proc pointers. */
9206 9514 : ss = gfc_walk_expr (arg1->expr);
9207 9514 : scalar = ss == gfc_ss_terminator;
9208 9514 : if (!scalar)
9209 3913 : gfc_free_ss_chain (ss);
9210 :
9211 9514 : if (!arg2->expr)
9212 : {
9213 : /* No optional target. */
9214 7135 : if (scalar)
9215 : {
9216 : /* A pointer to a scalar. */
9217 4674 : arg1se.want_pointer = 1;
9218 4674 : gfc_conv_expr (&arg1se, arg1->expr);
9219 4674 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9220 185 : && arg1->expr->symtree->n.sym->attr.dummy)
9221 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9222 : arg1se.expr);
9223 4674 : if (arg1->expr->ts.type == BT_CLASS)
9224 : {
9225 390 : tmp2 = gfc_class_data_get (arg1se.expr);
9226 390 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9227 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9228 : }
9229 : else
9230 4284 : tmp2 = arg1se.expr;
9231 : }
9232 : else
9233 : {
9234 : /* A pointer to an array. */
9235 2461 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9236 2461 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9237 : }
9238 7135 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9239 7135 : gfc_add_block_to_block (&se->post, &arg1se.post);
9240 7135 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9241 7135 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9242 7135 : se->expr = tmp;
9243 : }
9244 : else
9245 : {
9246 : /* An optional target. */
9247 2379 : if (arg2->expr->ts.type == BT_CLASS
9248 30 : && arg2->expr->expr_type != EXPR_FUNCTION)
9249 24 : gfc_add_data_component (arg2->expr);
9250 :
9251 2379 : if (scalar)
9252 : {
9253 : /* A pointer to a scalar. */
9254 927 : arg1se.want_pointer = 1;
9255 927 : gfc_conv_expr (&arg1se, arg1->expr);
9256 927 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9257 128 : && arg1->expr->symtree->n.sym->attr.dummy)
9258 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9259 : arg1se.expr);
9260 927 : if (arg1->expr->ts.type == BT_CLASS)
9261 254 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9262 :
9263 927 : arg2se.want_pointer = 1;
9264 927 : gfc_conv_expr (&arg2se, arg2->expr);
9265 927 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9266 36 : && arg2->expr->symtree->n.sym->attr.dummy)
9267 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9268 : arg2se.expr);
9269 927 : if (arg2->expr->ts.type == BT_CLASS)
9270 : {
9271 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9272 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
9273 : }
9274 927 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9275 927 : gfc_add_block_to_block (&se->post, &arg1se.post);
9276 927 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9277 927 : gfc_add_block_to_block (&se->post, &arg2se.post);
9278 927 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9279 : arg1se.expr, arg2se.expr);
9280 927 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9281 : arg1se.expr, null_pointer_node);
9282 927 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9283 : logical_type_node, tmp, tmp2);
9284 : }
9285 : else
9286 : {
9287 : /* An array pointer of zero length is not associated if target is
9288 : present. */
9289 1452 : arg1se.descriptor_only = 1;
9290 1452 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9291 1452 : if (arg1->expr->rank == -1)
9292 : {
9293 84 : tmp = gfc_conv_descriptor_rank (arg1se.expr);
9294 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9295 84 : TREE_TYPE (tmp), tmp,
9296 84 : build_int_cst (TREE_TYPE (tmp), 1));
9297 : }
9298 : else
9299 1368 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9300 1452 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9301 1452 : if (arg2->expr->rank != 0)
9302 1422 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9303 : logical_type_node, tmp,
9304 1422 : build_int_cst (TREE_TYPE (tmp), 0));
9305 :
9306 : /* A pointer to an array, call library function _gfor_associated. */
9307 1452 : arg1se.want_pointer = 1;
9308 1452 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9309 1452 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9310 1452 : gfc_add_block_to_block (&se->post, &arg1se.post);
9311 :
9312 1452 : arg2se.want_pointer = 1;
9313 1452 : arg2se.force_no_tmp = 1;
9314 1452 : if (arg2->expr->rank != 0)
9315 1422 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9316 : else
9317 : {
9318 30 : gfc_conv_expr (&arg2se, arg2->expr);
9319 30 : arg2se.expr
9320 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9321 30 : gfc_expr_attr (arg2->expr));
9322 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9323 : }
9324 1452 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9325 1452 : gfc_add_block_to_block (&se->post, &arg2se.post);
9326 1452 : se->expr = build_call_expr_loc (input_location,
9327 : gfor_fndecl_associated, 2,
9328 : arg1se.expr, arg2se.expr);
9329 1452 : se->expr = convert (logical_type_node, se->expr);
9330 1452 : if (arg2->expr->rank != 0)
9331 1422 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9332 : logical_type_node, se->expr,
9333 : nonzero_arraylen);
9334 : }
9335 :
9336 : /* If target is present zero character length pointers cannot
9337 : be associated. */
9338 2379 : if (arg1->expr->ts.type == BT_CHARACTER)
9339 : {
9340 631 : tmp = arg1se.string_length;
9341 631 : tmp = fold_build2_loc (input_location, NE_EXPR,
9342 : logical_type_node, tmp,
9343 631 : build_zero_cst (TREE_TYPE (tmp)));
9344 631 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9345 : logical_type_node, se->expr, tmp);
9346 : }
9347 : }
9348 :
9349 9514 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9350 9514 : }
9351 :
9352 :
9353 : /* Generate code for the SAME_TYPE_AS intrinsic.
9354 : Generate inline code that directly checks the vindices. */
9355 :
9356 : static void
9357 409 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9358 : {
9359 409 : gfc_expr *a, *b;
9360 409 : gfc_se se1, se2;
9361 409 : tree tmp;
9362 409 : tree conda = NULL_TREE, condb = NULL_TREE;
9363 :
9364 409 : gfc_init_se (&se1, NULL);
9365 409 : gfc_init_se (&se2, NULL);
9366 :
9367 409 : a = expr->value.function.actual->expr;
9368 409 : b = expr->value.function.actual->next->expr;
9369 :
9370 409 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9371 409 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9372 409 : if (unlimited_poly_a)
9373 : {
9374 111 : se1.want_pointer = 1;
9375 111 : gfc_add_vptr_component (a);
9376 : }
9377 298 : else if (a->ts.type == BT_CLASS)
9378 : {
9379 256 : gfc_add_vptr_component (a);
9380 256 : gfc_add_hash_component (a);
9381 : }
9382 42 : else if (a->ts.type == BT_DERIVED)
9383 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9384 42 : a->ts.u.derived->hash_value);
9385 :
9386 409 : if (unlimited_poly_b)
9387 : {
9388 72 : se2.want_pointer = 1;
9389 72 : gfc_add_vptr_component (b);
9390 : }
9391 337 : else if (b->ts.type == BT_CLASS)
9392 : {
9393 169 : gfc_add_vptr_component (b);
9394 169 : gfc_add_hash_component (b);
9395 : }
9396 168 : else if (b->ts.type == BT_DERIVED)
9397 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9398 168 : b->ts.u.derived->hash_value);
9399 :
9400 409 : gfc_conv_expr (&se1, a);
9401 409 : gfc_conv_expr (&se2, b);
9402 :
9403 409 : if (unlimited_poly_a)
9404 : {
9405 111 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9406 : se1.expr,
9407 111 : build_int_cst (TREE_TYPE (se1.expr), 0));
9408 111 : se1.expr = gfc_vptr_hash_get (se1.expr);
9409 : }
9410 :
9411 409 : if (unlimited_poly_b)
9412 : {
9413 72 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9414 : se2.expr,
9415 72 : build_int_cst (TREE_TYPE (se2.expr), 0));
9416 72 : se2.expr = gfc_vptr_hash_get (se2.expr);
9417 : }
9418 :
9419 409 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9420 : logical_type_node, se1.expr,
9421 409 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9422 :
9423 409 : if (conda)
9424 111 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9425 : logical_type_node, conda, tmp);
9426 :
9427 409 : if (condb)
9428 72 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9429 : logical_type_node, condb, tmp);
9430 :
9431 409 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9432 409 : }
9433 :
9434 :
9435 : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9436 :
9437 : static void
9438 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9439 : {
9440 42 : tree args[2];
9441 :
9442 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9443 42 : se->expr = build_call_expr_loc (input_location,
9444 : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9445 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9446 42 : }
9447 :
9448 :
9449 : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9450 :
9451 : static void
9452 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9453 : {
9454 45 : tree arg, type;
9455 :
9456 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9457 :
9458 : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9459 45 : type = gfc_get_int_type (4);
9460 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9461 :
9462 : /* Convert it to the required type. */
9463 45 : type = gfc_typenode_for_spec (&expr->ts);
9464 45 : se->expr = build_call_expr_loc (input_location,
9465 : gfor_fndecl_si_kind, 1, arg);
9466 45 : se->expr = fold_convert (type, se->expr);
9467 45 : }
9468 :
9469 :
9470 : /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9471 :
9472 : static void
9473 6 : gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9474 : {
9475 6 : tree arg, type;
9476 :
9477 6 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9478 :
9479 : /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9480 6 : type = gfc_get_int_type (4);
9481 6 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9482 :
9483 : /* Convert it to the required type. */
9484 6 : type = gfc_typenode_for_spec (&expr->ts);
9485 6 : se->expr = build_call_expr_loc (input_location,
9486 : gfor_fndecl_sl_kind, 1, arg);
9487 6 : se->expr = fold_convert (type, se->expr);
9488 6 : }
9489 :
9490 :
9491 : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9492 :
9493 : static void
9494 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9495 : {
9496 82 : gfc_actual_arglist *actual;
9497 82 : tree type;
9498 82 : gfc_se argse;
9499 82 : vec<tree, va_gc> *args = NULL;
9500 :
9501 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9502 : {
9503 246 : gfc_init_se (&argse, se);
9504 :
9505 : /* Pass a NULL pointer for an absent arg. */
9506 246 : if (actual->expr == NULL)
9507 96 : argse.expr = null_pointer_node;
9508 : else
9509 : {
9510 150 : gfc_typespec ts;
9511 150 : gfc_clear_ts (&ts);
9512 :
9513 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9514 : {
9515 : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9516 0 : ts.type = BT_INTEGER;
9517 0 : ts.kind = gfc_c_int_kind;
9518 0 : gfc_convert_type (actual->expr, &ts, 2);
9519 : }
9520 150 : gfc_conv_expr_reference (&argse, actual->expr);
9521 : }
9522 :
9523 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9524 246 : gfc_add_block_to_block (&se->post, &argse.post);
9525 246 : vec_safe_push (args, argse.expr);
9526 : }
9527 :
9528 : /* Convert it to the required type. */
9529 82 : type = gfc_typenode_for_spec (&expr->ts);
9530 82 : se->expr = build_call_expr_loc_vec (input_location,
9531 : gfor_fndecl_sr_kind, args);
9532 82 : se->expr = fold_convert (type, se->expr);
9533 82 : }
9534 :
9535 :
9536 : /* Generate code for TRIM (A) intrinsic function. */
9537 :
9538 : static void
9539 578 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9540 : {
9541 578 : tree var;
9542 578 : tree len;
9543 578 : tree addr;
9544 578 : tree tmp;
9545 578 : tree cond;
9546 578 : tree fndecl;
9547 578 : tree function;
9548 578 : tree *args;
9549 578 : unsigned int num_args;
9550 :
9551 578 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9552 578 : args = XALLOCAVEC (tree, num_args);
9553 :
9554 578 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9555 578 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9556 578 : len = gfc_create_var (gfc_charlen_type_node, "len");
9557 :
9558 578 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9559 578 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9560 578 : args[1] = addr;
9561 :
9562 578 : if (expr->ts.kind == 1)
9563 546 : function = gfor_fndecl_string_trim;
9564 32 : else if (expr->ts.kind == 4)
9565 32 : function = gfor_fndecl_string_trim_char4;
9566 : else
9567 0 : gcc_unreachable ();
9568 :
9569 578 : fndecl = build_addr (function);
9570 578 : tmp = build_call_array_loc (input_location,
9571 578 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9572 : num_args, args);
9573 578 : gfc_add_expr_to_block (&se->pre, tmp);
9574 :
9575 : /* Free the temporary afterwards, if necessary. */
9576 578 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9577 578 : len, build_int_cst (TREE_TYPE (len), 0));
9578 578 : tmp = gfc_call_free (var);
9579 578 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9580 578 : gfc_add_expr_to_block (&se->post, tmp);
9581 :
9582 578 : se->expr = var;
9583 578 : se->string_length = len;
9584 578 : }
9585 :
9586 :
9587 : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9588 :
9589 : static void
9590 529 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9591 : {
9592 529 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9593 529 : tree type, cond, tmp, count, exit_label, n, max, largest;
9594 529 : tree size;
9595 529 : stmtblock_t block, body;
9596 529 : int i;
9597 :
9598 : /* We store in charsize the size of a character. */
9599 529 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9600 529 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9601 :
9602 : /* Get the arguments. */
9603 529 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9604 529 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9605 529 : src = args[1];
9606 529 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9607 529 : ncopies_type = TREE_TYPE (ncopies);
9608 :
9609 : /* Check that NCOPIES is not negative. */
9610 529 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9611 : build_int_cst (ncopies_type, 0));
9612 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9613 : "Argument NCOPIES of REPEAT intrinsic is negative "
9614 : "(its value is %ld)",
9615 : fold_convert (long_integer_type_node, ncopies));
9616 :
9617 : /* If the source length is zero, any non negative value of NCOPIES
9618 : is valid, and nothing happens. */
9619 529 : n = gfc_create_var (ncopies_type, "ncopies");
9620 529 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9621 : size_zero_node);
9622 529 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9623 : build_int_cst (ncopies_type, 0), ncopies);
9624 529 : gfc_add_modify (&se->pre, n, tmp);
9625 529 : ncopies = n;
9626 :
9627 : /* Check that ncopies is not too large: ncopies should be less than
9628 : (or equal to) MAX / slen, where MAX is the maximal integer of
9629 : the gfc_charlen_type_node type. If slen == 0, we need a special
9630 : case to avoid the division by zero. */
9631 529 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9632 529 : fold_convert (sizetype,
9633 : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9634 : slen);
9635 1054 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9636 529 : ? sizetype : ncopies_type;
9637 529 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9638 : fold_convert (largest, ncopies),
9639 : fold_convert (largest, max));
9640 529 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9641 : size_zero_node);
9642 529 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9643 : logical_false_node, cond);
9644 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9645 : "Argument NCOPIES of REPEAT intrinsic is too large");
9646 :
9647 : /* Compute the destination length. */
9648 529 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9649 : fold_convert (gfc_charlen_type_node, slen),
9650 : fold_convert (gfc_charlen_type_node, ncopies));
9651 529 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9652 529 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9653 :
9654 : /* Generate the code to do the repeat operation:
9655 : for (i = 0; i < ncopies; i++)
9656 : memmove (dest + (i * slen * size), src, slen*size); */
9657 529 : gfc_start_block (&block);
9658 529 : count = gfc_create_var (sizetype, "count");
9659 529 : gfc_add_modify (&block, count, size_zero_node);
9660 529 : exit_label = gfc_build_label_decl (NULL_TREE);
9661 :
9662 : /* Start the loop body. */
9663 529 : gfc_start_block (&body);
9664 :
9665 : /* Exit the loop if count >= ncopies. */
9666 529 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9667 : fold_convert (sizetype, ncopies));
9668 529 : tmp = build1_v (GOTO_EXPR, exit_label);
9669 529 : TREE_USED (exit_label) = 1;
9670 529 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9671 : build_empty_stmt (input_location));
9672 529 : gfc_add_expr_to_block (&body, tmp);
9673 :
9674 : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9675 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9676 : count);
9677 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9678 : size);
9679 529 : tmp = fold_build_pointer_plus_loc (input_location,
9680 : fold_convert (pvoid_type_node, dest), tmp);
9681 529 : tmp = build_call_expr_loc (input_location,
9682 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9683 : 3, tmp, src,
9684 : fold_build2_loc (input_location, MULT_EXPR,
9685 : size_type_node, slen, size));
9686 529 : gfc_add_expr_to_block (&body, tmp);
9687 :
9688 : /* Increment count. */
9689 529 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9690 : count, size_one_node);
9691 529 : gfc_add_modify (&body, count, tmp);
9692 :
9693 : /* Build the loop. */
9694 529 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9695 529 : gfc_add_expr_to_block (&block, tmp);
9696 :
9697 : /* Add the exit label. */
9698 529 : tmp = build1_v (LABEL_EXPR, exit_label);
9699 529 : gfc_add_expr_to_block (&block, tmp);
9700 :
9701 : /* Finish the block. */
9702 529 : tmp = gfc_finish_block (&block);
9703 529 : gfc_add_expr_to_block (&se->pre, tmp);
9704 :
9705 : /* Set the result value. */
9706 529 : se->expr = dest;
9707 529 : se->string_length = dlen;
9708 529 : }
9709 :
9710 :
9711 : /* Generate code for the IARGC intrinsic. */
9712 :
9713 : static void
9714 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9715 : {
9716 12 : tree tmp;
9717 12 : tree fndecl;
9718 12 : tree type;
9719 :
9720 : /* Call the library function. This always returns an INTEGER(4). */
9721 12 : fndecl = gfor_fndecl_iargc;
9722 12 : tmp = build_call_expr_loc (input_location,
9723 : fndecl, 0);
9724 :
9725 : /* Convert it to the required type. */
9726 12 : type = gfc_typenode_for_spec (&expr->ts);
9727 12 : tmp = fold_convert (type, tmp);
9728 :
9729 12 : se->expr = tmp;
9730 12 : }
9731 :
9732 :
9733 : /* Generate code for the KILL intrinsic. */
9734 :
9735 : static void
9736 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9737 : {
9738 8 : tree *args;
9739 8 : tree int4_type_node = gfc_get_int_type (4);
9740 8 : tree pid;
9741 8 : tree sig;
9742 8 : tree tmp;
9743 8 : unsigned int num_args;
9744 :
9745 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9746 8 : args = XALLOCAVEC (tree, num_args);
9747 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9748 :
9749 : /* Convert PID to a INTEGER(4) entity. */
9750 8 : pid = convert (int4_type_node, args[0]);
9751 :
9752 : /* Convert SIG to a INTEGER(4) entity. */
9753 8 : sig = convert (int4_type_node, args[1]);
9754 :
9755 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9756 :
9757 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9758 8 : }
9759 :
9760 :
9761 : static tree
9762 15 : conv_intrinsic_kill_sub (gfc_code *code)
9763 : {
9764 15 : stmtblock_t block;
9765 15 : gfc_se se, se_stat;
9766 15 : tree int4_type_node = gfc_get_int_type (4);
9767 15 : tree pid;
9768 15 : tree sig;
9769 15 : tree statp;
9770 15 : tree tmp;
9771 :
9772 : /* Make the function call. */
9773 15 : gfc_init_block (&block);
9774 15 : gfc_init_se (&se, NULL);
9775 :
9776 : /* Convert PID to a INTEGER(4) entity. */
9777 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9778 15 : gfc_add_block_to_block (&block, &se.pre);
9779 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9780 15 : gfc_add_block_to_block (&block, &se.post);
9781 :
9782 : /* Convert SIG to a INTEGER(4) entity. */
9783 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9784 15 : gfc_add_block_to_block (&block, &se.pre);
9785 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9786 15 : gfc_add_block_to_block (&block, &se.post);
9787 :
9788 : /* Deal with an optional STATUS. */
9789 15 : if (code->ext.actual->next->next->expr)
9790 : {
9791 10 : gfc_init_se (&se_stat, NULL);
9792 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9793 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9794 : }
9795 : else
9796 : statp = NULL_TREE;
9797 :
9798 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9799 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9800 :
9801 15 : gfc_add_expr_to_block (&block, tmp);
9802 :
9803 15 : if (statp && statp != se_stat.expr)
9804 10 : gfc_add_modify (&block, se_stat.expr,
9805 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9806 :
9807 15 : return gfc_finish_block (&block);
9808 : }
9809 :
9810 :
9811 :
9812 : /* The loc intrinsic returns the address of its argument as
9813 : gfc_index_integer_kind integer. */
9814 :
9815 : static void
9816 8860 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9817 : {
9818 8860 : tree temp_var;
9819 8860 : gfc_expr *arg_expr;
9820 :
9821 8860 : gcc_assert (!se->ss);
9822 :
9823 8860 : arg_expr = expr->value.function.actual->expr;
9824 8860 : if (arg_expr->rank == 0)
9825 : {
9826 6443 : if (arg_expr->ts.type == BT_CLASS)
9827 18 : gfc_add_data_component (arg_expr);
9828 6443 : gfc_conv_expr_reference (se, arg_expr);
9829 : }
9830 2417 : else if (gfc_is_simply_contiguous (arg_expr, false, false))
9831 2380 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9832 : else
9833 : {
9834 37 : gfc_conv_expr_descriptor (se, arg_expr);
9835 37 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9836 : }
9837 8860 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9838 8860 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9839 :
9840 : /* Create a temporary variable for loc return value. Without this,
9841 : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9842 8860 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9843 8860 : gfc_add_modify (&se->pre, temp_var, se->expr);
9844 8860 : se->expr = temp_var;
9845 8860 : }
9846 :
9847 : /* The following routine generates code for the intrinsic functions from
9848 : the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9849 : F_C_STRING. */
9850 :
9851 : static void
9852 9794 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9853 : {
9854 9794 : gfc_actual_arglist *arg = expr->value.function.actual;
9855 :
9856 9794 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9857 : {
9858 7404 : if (arg->expr->rank == 0)
9859 2010 : gfc_conv_expr_reference (se, arg->expr);
9860 5394 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9861 4310 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9862 : else
9863 : {
9864 1084 : gfc_conv_expr_descriptor (se, arg->expr);
9865 1084 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9866 : }
9867 :
9868 : /* TODO -- the following two lines shouldn't be necessary, but if
9869 : they're removed, a bug is exposed later in the code path.
9870 : This workaround was thus introduced, but will have to be
9871 : removed; please see PR 35150 for details about the issue. */
9872 7404 : se->expr = convert (pvoid_type_node, se->expr);
9873 7404 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9874 : }
9875 2390 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9876 : {
9877 260 : gfc_conv_expr_reference (se, arg->expr);
9878 260 : if (arg->expr->symtree->n.sym->attr.proc_pointer
9879 29 : && arg->expr->symtree->n.sym->attr.dummy)
9880 7 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9881 : /* The code below is necessary to create a reference from the calling
9882 : subprogram to the argument of C_FUNLOC() in the call graph.
9883 : Please see PR 117303 for more details. */
9884 260 : se->expr = convert (pvoid_type_node, se->expr);
9885 260 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9886 : }
9887 2130 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9888 : {
9889 2054 : gfc_se arg1se;
9890 2054 : gfc_se arg2se;
9891 :
9892 : /* Build the addr_expr for the first argument. The argument is
9893 : already an *address* so we don't need to set want_pointer in
9894 : the gfc_se. */
9895 2054 : gfc_init_se (&arg1se, NULL);
9896 2054 : gfc_conv_expr (&arg1se, arg->expr);
9897 2054 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9898 2054 : gfc_add_block_to_block (&se->post, &arg1se.post);
9899 :
9900 : /* See if we were given two arguments. */
9901 2054 : if (arg->next->expr == NULL)
9902 : /* Only given one arg so generate a null and do a
9903 : not-equal comparison against the first arg. */
9904 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9905 : arg1se.expr,
9906 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9907 : null_pointer_node));
9908 : else
9909 : {
9910 379 : tree eq_expr;
9911 379 : tree not_null_expr;
9912 :
9913 : /* Given two arguments so build the arg2se from second arg. */
9914 379 : gfc_init_se (&arg2se, NULL);
9915 379 : gfc_conv_expr (&arg2se, arg->next->expr);
9916 379 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9917 379 : gfc_add_block_to_block (&se->post, &arg2se.post);
9918 :
9919 : /* Generate test to compare that the two args are equal. */
9920 379 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9921 : arg1se.expr, arg2se.expr);
9922 : /* Generate test to ensure that the first arg is not null. */
9923 379 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9924 : logical_type_node,
9925 : arg1se.expr, null_pointer_node);
9926 :
9927 : /* Finally, the generated test must check that both arg1 is not
9928 : NULL and that it is equal to the second arg. */
9929 379 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9930 : logical_type_node,
9931 : not_null_expr, eq_expr);
9932 : }
9933 : }
9934 76 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9935 : {
9936 : /* There are three cases:
9937 : f_c_string(string) -> trim(string) // c_null_char
9938 : f_c_string(string, .false.) -> trim(string) // c_null_char
9939 : f_c_string(string, .true.) -> string // c_null_char */
9940 :
9941 76 : gfc_expr *string = arg->expr;
9942 76 : gfc_expr *asis = arg->next->expr;
9943 76 : bool need_asis = false, need_trim = false;
9944 76 : gfc_se asis_se;
9945 :
9946 76 : if (!asis)
9947 : {
9948 : need_trim = true;
9949 : need_asis = false;
9950 : }
9951 54 : else if (asis->expr_type == EXPR_CONSTANT)
9952 : {
9953 32 : need_asis = asis->value.logical;
9954 32 : need_trim = !need_asis;
9955 : }
9956 : else
9957 : {
9958 : /* A conditional expression is needed. */
9959 22 : need_asis = true;
9960 22 : need_trim = true;
9961 22 : gfc_init_se (&asis_se, se);
9962 22 : gfc_conv_expr (&asis_se, asis);
9963 22 : if (asis->expr_type == EXPR_VARIABLE
9964 22 : && asis->symtree->n.sym->attr.dummy
9965 10 : && asis->symtree->n.sym->attr.optional)
9966 : {
9967 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
9968 6 : asis_se.expr
9969 6 : = build3_loc (input_location, COND_EXPR,
9970 : logical_type_node, present,
9971 : asis_se.expr, logical_false_node);
9972 : }
9973 22 : gfc_make_safe_expr (&asis_se);
9974 : }
9975 :
9976 : /* Handle the case of a constant string argument first. */
9977 76 : if (string->expr_type == EXPR_CONSTANT)
9978 : {
9979 : /* Output for the asis "then" case goes tlen/tstr, and the
9980 : trimmed case in elen/estr. */
9981 34 : tree elen, estr, tlen, tstr;
9982 34 : elen = estr = tlen = tstr = NULL_TREE;
9983 :
9984 34 : gfc_char_t *orig_string = string->value.character.string;
9985 34 : gfc_charlen_t orig_len = string->value.character.length;
9986 34 : gfc_charlen_t n;
9987 34 : gfc_char_t *buf
9988 34 : = (gfc_char_t *) alloca ((orig_len + 1) * sizeof (gfc_char_t));
9989 34 : memcpy (buf, orig_string, orig_len * sizeof (gfc_char_t));
9990 34 : buf[orig_len] = '\0';
9991 34 : int kind = gfc_default_character_kind;
9992 34 : gcc_assert (string->ts.kind == kind);
9993 :
9994 : /* Build the new string constant(s). */
9995 34 : if (need_asis)
9996 : {
9997 14 : tstr = gfc_build_wide_string_const (kind, orig_len + 1, buf);
9998 14 : tlen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tstr)));
9999 14 : if (!need_trim)
10000 : {
10001 10 : se->expr = tstr;
10002 10 : se->string_length = tlen;
10003 10 : return;
10004 : }
10005 : }
10006 24 : if (need_trim)
10007 : {
10008 72 : for (n = orig_len; n; n--)
10009 72 : if (buf[n - 1] != ' ')
10010 : break;
10011 24 : buf[n] = '\0';
10012 24 : if (need_asis && n == orig_len)
10013 : {
10014 : /* Special case; trimming is a no-op. Add side-effects
10015 : from the condition and then just return the string
10016 : without a conditional. */
10017 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10018 2 : se->expr = tstr;
10019 2 : se->string_length = tlen;
10020 2 : return;
10021 : }
10022 : else
10023 : {
10024 22 : estr = gfc_build_wide_string_const (kind, n + 1, buf);
10025 22 : elen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (estr)));
10026 : }
10027 22 : if (!need_asis)
10028 : {
10029 20 : se->expr = estr;
10030 20 : se->string_length = elen;
10031 20 : return;
10032 : }
10033 : }
10034 0 : gcc_assert (need_asis && need_trim);
10035 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10036 2 : se->expr
10037 2 : = fold_build3_loc (input_location, COND_EXPR,
10038 : pchar_type_node, asis_se.expr,
10039 : tstr, estr);
10040 2 : se->string_length
10041 2 : = fold_build3_loc (input_location, COND_EXPR,
10042 : gfc_charlen_type_node, asis_se.expr,
10043 : tlen, elen);
10044 2 : return;
10045 : }
10046 : else
10047 : /* We have to generate code to do the string transformation(s) at
10048 : runtime. */
10049 : {
10050 42 : tree tmp;
10051 :
10052 : /* Convert input string. */
10053 42 : gfc_se sse;
10054 42 : gfc_init_se (&sse, se);
10055 42 : gfc_conv_expr (&sse, string);
10056 42 : gfc_conv_string_parameter (&sse);
10057 42 : gfc_make_safe_expr (&sse);
10058 42 : gfc_add_block_to_block (&se->pre, &sse.pre);
10059 :
10060 : /* Use a temporary for the (possibly trimmed) string length. */
10061 42 : tree lenvar = gfc_create_var (gfc_charlen_type_node, NULL);
10062 42 : gfc_add_modify (&se->pre, lenvar, sse.string_length);
10063 :
10064 : /* Build the expression for a call to LEN_TRIM if we may need
10065 : to trim the string. If it's conditional, handle that too. */
10066 42 : if (need_trim)
10067 : {
10068 36 : tree trimlen
10069 36 : = build_call_expr_loc (input_location,
10070 : gfor_fndecl_string_len_trim, 2,
10071 : lenvar, sse.expr);
10072 36 : if (need_asis)
10073 : {
10074 18 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10075 18 : tmp = fold_build3_loc (input_location, COND_EXPR,
10076 : gfc_charlen_type_node, asis_se.expr,
10077 : lenvar, trimlen);
10078 18 : gfc_add_modify (&se->pre, lenvar, tmp);
10079 : }
10080 : else
10081 18 : gfc_add_modify (&se->pre, lenvar, trimlen);
10082 : }
10083 :
10084 : /* Allocate a new string newvar that is lenvar+1 bytes long.
10085 : memcpy the first lenvar bytes from the input string, and
10086 : add a null character. Note that lenvar, the length of
10087 : the (trimmed) original string, has type gfc_charlen_type_node,
10088 : but newlen is size_type_node. */
10089 42 : tree string_type_node = build_pointer_type (char_type_node);
10090 42 : tree newvar = gfc_create_var (string_type_node, NULL);
10091 42 : tree newlen = fold_build2_loc (input_location, PLUS_EXPR,
10092 : size_type_node,
10093 : fold_convert (size_type_node,
10094 : lenvar),
10095 : size_one_node);
10096 42 : gfc_add_modify (&se->pre, newvar,
10097 : gfc_call_malloc (&se->pre, string_type_node,
10098 : newlen));
10099 42 : tmp = build_call_expr_loc (input_location,
10100 : builtin_decl_explicit (BUILT_IN_MEMCPY),
10101 : 3,
10102 : fold_convert (pvoid_type_node, newvar),
10103 : fold_convert (pvoid_type_node, sse.expr),
10104 : fold_convert (size_type_node, lenvar));
10105 42 : gfc_add_expr_to_block (&se->pre, tmp);
10106 42 : tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
10107 : string_type_node, newvar,
10108 : fold_convert (size_type_node, lenvar));
10109 42 : tmp = fold_build1_loc (input_location, INDIRECT_REF,
10110 : char_type_node, tmp);
10111 42 : gfc_add_modify (&se->pre, tmp,
10112 : fold_convert (char_type_node, integer_zero_node));
10113 :
10114 : /* Remember to free the string later. */
10115 42 : tmp = gfc_call_free (newvar);
10116 42 : gfc_add_expr_to_block (&se->post, tmp);
10117 :
10118 : /* Return the result. */
10119 42 : se->expr = newvar;
10120 42 : se->string_length = fold_convert (gfc_charlen_type_node, newlen);
10121 42 : return;
10122 : }
10123 : }
10124 : else
10125 0 : gcc_unreachable ();
10126 : }
10127 :
10128 :
10129 : /* The following routine generates code for the intrinsic
10130 : subroutines from the ISO_C_BINDING module:
10131 : * C_F_POINTER
10132 : * C_F_PROCPOINTER. */
10133 :
10134 : static tree
10135 3218 : conv_isocbinding_subroutine (gfc_code *code)
10136 : {
10137 3218 : gfc_expr *cptr, *fptr, *shape, *lower;
10138 3218 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10139 3218 : gfc_ss *shape_ss, *lower_ss;
10140 3218 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10141 3218 : stmtblock_t body, block;
10142 3218 : gfc_loopinfo loop;
10143 3218 : gfc_actual_arglist *arg;
10144 :
10145 3218 : arg = code->ext.actual;
10146 3218 : cptr = arg->expr;
10147 3218 : fptr = arg->next->expr;
10148 3218 : shape = arg->next->next ? arg->next->next->expr : NULL;
10149 3136 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10150 :
10151 3218 : gfc_init_se (&se, NULL);
10152 3218 : gfc_init_se (&cptrse, NULL);
10153 3218 : gfc_conv_expr (&cptrse, cptr);
10154 3218 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10155 3218 : gfc_add_block_to_block (&se.post, &cptrse.post);
10156 :
10157 3218 : gfc_init_se (&fptrse, NULL);
10158 3218 : if (fptr->rank == 0)
10159 : {
10160 2733 : fptrse.want_pointer = 1;
10161 2733 : gfc_conv_expr (&fptrse, fptr);
10162 2733 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10163 2733 : gfc_add_block_to_block (&se.post, &fptrse.post);
10164 2733 : if (fptr->symtree->n.sym->attr.proc_pointer
10165 81 : && fptr->symtree->n.sym->attr.dummy)
10166 19 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10167 2733 : se.expr
10168 2733 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10169 : fptrse.expr,
10170 2733 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10171 2733 : gfc_add_expr_to_block (&se.pre, se.expr);
10172 2733 : gfc_add_block_to_block (&se.pre, &se.post);
10173 2733 : return gfc_finish_block (&se.pre);
10174 : }
10175 :
10176 485 : gfc_start_block (&block);
10177 :
10178 : /* Get the descriptor of the Fortran pointer. */
10179 485 : fptrse.descriptor_only = 1;
10180 485 : gfc_conv_expr_descriptor (&fptrse, fptr);
10181 485 : gfc_add_block_to_block (&block, &fptrse.pre);
10182 485 : desc = fptrse.expr;
10183 :
10184 : /* Set the span field. */
10185 485 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10186 485 : tmp = fold_convert (gfc_array_index_type, tmp);
10187 485 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10188 :
10189 : /* Set data value, dtype, and offset. */
10190 485 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10191 485 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10192 485 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
10193 485 : gfc_get_dtype (TREE_TYPE (desc)));
10194 :
10195 : /* Start scalarization of the bounds, using the shape argument. */
10196 :
10197 485 : shape_ss = gfc_walk_expr (shape);
10198 485 : gcc_assert (shape_ss != gfc_ss_terminator);
10199 485 : gfc_init_se (&shapese, NULL);
10200 485 : if (lower)
10201 : {
10202 12 : lower_ss = gfc_walk_expr (lower);
10203 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10204 12 : gfc_init_se (&lowerse, NULL);
10205 : }
10206 :
10207 485 : gfc_init_loopinfo (&loop);
10208 485 : gfc_add_ss_to_loop (&loop, shape_ss);
10209 485 : if (lower)
10210 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10211 485 : gfc_conv_ss_startstride (&loop);
10212 485 : gfc_conv_loop_setup (&loop, &fptr->where);
10213 485 : gfc_mark_ss_chain_used (shape_ss, 1);
10214 485 : if (lower)
10215 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10216 :
10217 485 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10218 485 : shapese.ss = shape_ss;
10219 485 : if (lower)
10220 : {
10221 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10222 12 : lowerse.ss = lower_ss;
10223 : }
10224 :
10225 485 : stride = gfc_create_var (gfc_array_index_type, "stride");
10226 485 : offset = gfc_create_var (gfc_array_index_type, "offset");
10227 485 : gfc_add_modify (&block, stride, gfc_index_one_node);
10228 485 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10229 :
10230 : /* Loop body. */
10231 485 : gfc_start_scalarized_body (&loop, &body);
10232 :
10233 485 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10234 : loop.loopvar[0], loop.from[0]);
10235 :
10236 485 : if (lower)
10237 : {
10238 12 : gfc_conv_expr (&lowerse, lower);
10239 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10240 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10241 12 : gfc_add_block_to_block (&body, &lowerse.post);
10242 : }
10243 : else
10244 473 : lbound = gfc_index_one_node;
10245 :
10246 : /* Set bounds and stride. */
10247 485 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10248 485 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10249 :
10250 485 : gfc_conv_expr (&shapese, shape);
10251 485 : gfc_add_block_to_block (&body, &shapese.pre);
10252 485 : ubound = fold_build2_loc (
10253 : input_location, MINUS_EXPR, gfc_array_index_type,
10254 : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10255 : fold_convert (gfc_array_index_type, shapese.expr)),
10256 : gfc_index_one_node);
10257 485 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10258 485 : gfc_add_block_to_block (&body, &shapese.post);
10259 :
10260 : /* Calculate offset. */
10261 485 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10262 : stride, lbound);
10263 485 : gfc_add_modify (&body, offset,
10264 : fold_build2_loc (input_location, PLUS_EXPR,
10265 : gfc_array_index_type, offset, tmp));
10266 :
10267 : /* Update stride. */
10268 485 : gfc_add_modify (
10269 : &body, stride,
10270 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10271 : fold_convert (gfc_array_index_type, shapese.expr)));
10272 : /* Finish scalarization loop. */
10273 485 : gfc_trans_scalarizing_loops (&loop, &body);
10274 485 : gfc_add_block_to_block (&block, &loop.pre);
10275 485 : gfc_add_block_to_block (&block, &loop.post);
10276 485 : gfc_add_block_to_block (&block, &fptrse.post);
10277 485 : gfc_cleanup_loop (&loop);
10278 :
10279 485 : gfc_add_modify (&block, offset,
10280 : fold_build1_loc (input_location, NEGATE_EXPR,
10281 : gfc_array_index_type, offset));
10282 485 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10283 :
10284 485 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10285 485 : gfc_add_block_to_block (&se.pre, &se.post);
10286 485 : return gfc_finish_block (&se.pre);
10287 : }
10288 :
10289 :
10290 : /* The following routine generates code for both forms of the intrinsic
10291 : subroutine C_F_STRPOINTER from the ISO_C_BINDING module. */
10292 : static tree
10293 60 : conv_isocbinding_subroutine_strpointer (gfc_code *code)
10294 : {
10295 60 : gfc_actual_arglist *arg = code->ext.actual;
10296 60 : gfc_expr *arg0 = arg->expr;
10297 60 : gfc_expr *fstrptr = arg->next->expr;
10298 60 : gfc_expr *nchars = arg->next->next->expr;
10299 60 : tree ptr;
10300 60 : tree size = NULL_TREE;
10301 60 : tree nc = NULL_TREE;
10302 60 : tree fstrptr_ptr, fstrptr_len;
10303 60 : stmtblock_t block;
10304 60 : gfc_init_block (&block);
10305 60 : gfc_se se0, se1, se2;
10306 60 : gfc_init_se (&se0, NULL);
10307 60 : gfc_init_se (&se1, NULL);
10308 60 : gfc_init_se (&se2, NULL);
10309 :
10310 : /* arg0 can either be a simply contiguous rank-one character array,
10311 : or a scalar of type c_ptr that points to a contiguous array.
10312 : In the first case nchars may be omitted and defaults to the size
10313 : of the array. */
10314 60 : if (arg0->rank == 1)
10315 : {
10316 42 : gfc_array_ref *ar = gfc_find_array_ref (arg0);
10317 42 : if (ar->as && ar->as->type == AS_ASSUMED_SIZE
10318 12 : && (ar->type == AR_FULL || ar->end[0] == nullptr))
10319 : /* No size available. */
10320 12 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, NULL);
10321 : else
10322 : {
10323 30 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, &size);
10324 30 : gcc_assert (size);
10325 : }
10326 42 : ptr = se0.expr;
10327 : }
10328 18 : else if (arg0->rank == 0)
10329 : {
10330 : /* Scalar case. arg0 is a C pointer to the string, and the
10331 : nchars argument is required. */
10332 18 : gfc_conv_expr (&se0, arg0);
10333 18 : ptr = se0.expr;
10334 : /* We already issued a diagnostic for this in parsing. */
10335 18 : gcc_assert (nchars);
10336 : }
10337 : else
10338 0 : gcc_unreachable ();
10339 :
10340 : /* Translate the fortran array pointer argument. AFAICT the
10341 : representation here is that this returns the pointer location in
10342 : se1.expr and there is a separate decl for the length.
10343 : Of course none of this is properly documented.... :-( */
10344 60 : gfc_conv_expr (&se1, fstrptr);
10345 60 : fstrptr_ptr = se1.expr;
10346 60 : gcc_assert (fstrptr->ts.u.cl && fstrptr->ts.u.cl->backend_decl);
10347 60 : fstrptr_len = fstrptr->ts.u.cl->backend_decl;
10348 :
10349 : /* Translate nchars, if provided. If we have both the array size
10350 : and nchars, take the minimum value. NC is the tree expr to hold
10351 : the value. */
10352 60 : if (nchars)
10353 : {
10354 30 : gfc_conv_expr (&se2, nchars);
10355 30 : nc = se2.expr;
10356 30 : if (size)
10357 0 : nc = fold_build2_loc (input_location, MIN_EXPR,
10358 0 : TREE_TYPE (nc), nc, size);
10359 : /* Check for the case where an optional dummy parameter is
10360 : passed as the optional nchars argument. It's not supposed to
10361 : be omitted if we don't also have an array size; rather than
10362 : produce a run-time error, assume size 0. */
10363 30 : if (nchars->expr_type == EXPR_VARIABLE
10364 18 : && nchars->symtree->n.sym->attr.dummy
10365 18 : && nchars->symtree->n.sym->attr.optional)
10366 : {
10367 12 : tree present = gfc_conv_expr_present (nchars->symtree->n.sym);
10368 12 : nc = build3_loc (input_location, COND_EXPR,
10369 12 : TREE_TYPE (nc), present, nc,
10370 24 : size ? size : build_int_cst (TREE_TYPE (nc), 0));
10371 : }
10372 : }
10373 : else
10374 : {
10375 30 : gcc_assert (size);
10376 : nc = size;
10377 : }
10378 :
10379 : /* Collect argument side-effect statements. */
10380 60 : gfc_add_block_to_block (&block, &se0.pre);
10381 60 : gfc_add_block_to_block (&block, &se1.pre);
10382 60 : gfc_add_block_to_block (&block, &se2.pre);
10383 :
10384 : /* Generate a call to builtin_strnlen to get the C string length
10385 : for the output fstrptr. */
10386 60 : ptr = gfc_evaluate_now (ptr, &block);
10387 60 : size = build_call_expr_loc (input_location,
10388 : builtin_decl_explicit (BUILT_IN_STRNLEN), 2,
10389 : fold_convert (const_ptr_type_node, ptr),
10390 : fold_convert (size_type_node, nc));
10391 :
10392 : /* Stuff the raw C char pointer PTR and actual length SIZE into fstrptr. */
10393 60 : gfc_add_modify (&block, fstrptr_ptr,
10394 60 : fold_convert (TREE_TYPE (fstrptr_ptr), ptr));
10395 60 : gfc_add_modify (&block, fstrptr_len,
10396 : fold_convert (gfc_charlen_type_node, size));
10397 :
10398 : /* Collect argument cleanups. */
10399 60 : gfc_add_block_to_block (&block, &se2.post);
10400 60 : gfc_add_block_to_block (&block, &se1.post);
10401 60 : gfc_add_block_to_block (&block, &se0.post);
10402 :
10403 60 : return gfc_finish_block (&block);
10404 : }
10405 :
10406 : /* Save and restore floating-point state. */
10407 :
10408 : tree
10409 948 : gfc_save_fp_state (stmtblock_t *block)
10410 : {
10411 948 : tree type, fpstate, tmp;
10412 :
10413 948 : type = build_array_type (char_type_node,
10414 : build_range_type (size_type_node, size_zero_node,
10415 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10416 948 : fpstate = gfc_create_var (type, "fpstate");
10417 948 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10418 :
10419 948 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10420 : 1, fpstate);
10421 948 : gfc_add_expr_to_block (block, tmp);
10422 :
10423 948 : return fpstate;
10424 : }
10425 :
10426 :
10427 : void
10428 948 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10429 : {
10430 948 : tree tmp;
10431 :
10432 948 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10433 : 1, fpstate);
10434 948 : gfc_add_expr_to_block (block, tmp);
10435 948 : }
10436 :
10437 :
10438 : /* Generate code for arguments of IEEE functions. */
10439 :
10440 : static void
10441 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10442 : int nargs)
10443 : {
10444 12457 : gfc_actual_arglist *actual;
10445 12457 : gfc_expr *e;
10446 12457 : gfc_se argse;
10447 12457 : int arg;
10448 :
10449 12457 : actual = expr->value.function.actual;
10450 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10451 : {
10452 22004 : gcc_assert (actual);
10453 22004 : e = actual->expr;
10454 :
10455 22004 : gfc_init_se (&argse, se);
10456 22004 : gfc_conv_expr_val (&argse, e);
10457 :
10458 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10459 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10460 22004 : argarray[arg] = argse.expr;
10461 : }
10462 12457 : }
10463 :
10464 :
10465 : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10466 : and IEEE_UNORDERED, which translate directly to GCC type-generic
10467 : built-ins. */
10468 :
10469 : static void
10470 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10471 : enum built_in_function code, int nargs)
10472 : {
10473 1062 : tree args[2];
10474 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10475 :
10476 1062 : conv_ieee_function_args (se, expr, args, nargs);
10477 1062 : se->expr = build_call_expr_loc_array (input_location,
10478 : builtin_decl_explicit (code),
10479 : nargs, args);
10480 2388 : STRIP_TYPE_NOPS (se->expr);
10481 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10482 1062 : }
10483 :
10484 :
10485 : /* Generate code for intrinsics IEEE_SIGNBIT. */
10486 :
10487 : static void
10488 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10489 : {
10490 624 : tree arg, signbit;
10491 :
10492 624 : conv_ieee_function_args (se, expr, &arg, 1);
10493 624 : signbit = build_call_expr_loc (input_location,
10494 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10495 : 1, arg);
10496 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10497 : signbit, integer_zero_node);
10498 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10499 624 : }
10500 :
10501 :
10502 : /* Generate code for IEEE_IS_NORMAL intrinsic:
10503 : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10504 :
10505 : static void
10506 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10507 : {
10508 312 : tree arg, isnormal, iszero;
10509 :
10510 : /* Convert arg, evaluate it only once. */
10511 312 : conv_ieee_function_args (se, expr, &arg, 1);
10512 312 : arg = gfc_evaluate_now (arg, &se->pre);
10513 :
10514 312 : isnormal = build_call_expr_loc (input_location,
10515 : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10516 : 1, arg);
10517 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10518 312 : build_real_from_int_cst (TREE_TYPE (arg),
10519 312 : integer_zero_node));
10520 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10521 : logical_type_node, isnormal, iszero);
10522 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10523 312 : }
10524 :
10525 :
10526 : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10527 : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10528 :
10529 : static void
10530 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10531 : {
10532 312 : tree arg, signbit, isnan;
10533 :
10534 : /* Convert arg, evaluate it only once. */
10535 312 : conv_ieee_function_args (se, expr, &arg, 1);
10536 312 : arg = gfc_evaluate_now (arg, &se->pre);
10537 :
10538 312 : isnan = build_call_expr_loc (input_location,
10539 : builtin_decl_explicit (BUILT_IN_ISNAN),
10540 : 1, arg);
10541 936 : STRIP_TYPE_NOPS (isnan);
10542 :
10543 312 : signbit = build_call_expr_loc (input_location,
10544 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10545 : 1, arg);
10546 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10547 : signbit, integer_zero_node);
10548 :
10549 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10550 : logical_type_node, signbit,
10551 : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10552 312 : TREE_TYPE(isnan), isnan));
10553 :
10554 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10555 312 : }
10556 :
10557 :
10558 : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10559 :
10560 : static void
10561 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10562 : enum built_in_function code)
10563 : {
10564 240 : tree arg, decl, call, fpstate;
10565 240 : int argprec;
10566 :
10567 240 : conv_ieee_function_args (se, expr, &arg, 1);
10568 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10569 240 : decl = builtin_decl_for_precision (code, argprec);
10570 :
10571 : /* Save floating-point state. */
10572 240 : fpstate = gfc_save_fp_state (&se->pre);
10573 :
10574 : /* Make the function call. */
10575 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10576 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10577 :
10578 : /* Restore floating-point state. */
10579 240 : gfc_restore_fp_state (&se->post, fpstate);
10580 240 : }
10581 :
10582 :
10583 : /* Generate code for IEEE_REM. */
10584 :
10585 : static void
10586 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10587 : {
10588 84 : tree args[2], decl, call, fpstate;
10589 84 : int argprec;
10590 :
10591 84 : conv_ieee_function_args (se, expr, args, 2);
10592 :
10593 : /* If arguments have unequal size, convert them to the larger. */
10594 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10595 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10596 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10597 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10598 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10599 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10600 :
10601 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10602 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10603 :
10604 : /* Save floating-point state. */
10605 84 : fpstate = gfc_save_fp_state (&se->pre);
10606 :
10607 : /* Make the function call. */
10608 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10609 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10610 :
10611 : /* Restore floating-point state. */
10612 84 : gfc_restore_fp_state (&se->post, fpstate);
10613 84 : }
10614 :
10615 :
10616 : /* Generate code for IEEE_NEXT_AFTER. */
10617 :
10618 : static void
10619 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10620 : {
10621 180 : tree args[2], decl, call, fpstate;
10622 180 : int argprec;
10623 :
10624 180 : conv_ieee_function_args (se, expr, args, 2);
10625 :
10626 : /* Result has the characteristics of first argument. */
10627 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10628 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10629 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10630 :
10631 : /* Save floating-point state. */
10632 180 : fpstate = gfc_save_fp_state (&se->pre);
10633 :
10634 : /* Make the function call. */
10635 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10636 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10637 :
10638 : /* Restore floating-point state. */
10639 180 : gfc_restore_fp_state (&se->post, fpstate);
10640 180 : }
10641 :
10642 :
10643 : /* Generate code for IEEE_SCALB. */
10644 :
10645 : static void
10646 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10647 : {
10648 228 : tree args[2], decl, call, huge, type;
10649 228 : int argprec, n;
10650 :
10651 228 : conv_ieee_function_args (se, expr, args, 2);
10652 :
10653 : /* Result has the characteristics of first argument. */
10654 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10655 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10656 :
10657 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10658 : {
10659 : /* We need to fold the integer into the range of a C int. */
10660 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10661 18 : type = TREE_TYPE (args[1]);
10662 :
10663 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10664 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10665 : gfc_c_int_kind);
10666 18 : huge = fold_convert (type, huge);
10667 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10668 : huge);
10669 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10670 : fold_build1_loc (input_location, NEGATE_EXPR,
10671 : type, huge));
10672 : }
10673 :
10674 228 : args[1] = fold_convert (integer_type_node, args[1]);
10675 :
10676 : /* Make the function call. */
10677 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10678 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10679 228 : }
10680 :
10681 :
10682 : /* Generate code for IEEE_COPY_SIGN. */
10683 :
10684 : static void
10685 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10686 : {
10687 576 : tree args[2], decl, sign;
10688 576 : int argprec;
10689 :
10690 576 : conv_ieee_function_args (se, expr, args, 2);
10691 :
10692 : /* Get the sign of the second argument. */
10693 576 : sign = build_call_expr_loc (input_location,
10694 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10695 : 1, args[1]);
10696 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10697 : sign, integer_zero_node);
10698 :
10699 : /* Create a value of one, with the right sign. */
10700 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10701 : sign,
10702 : fold_build1_loc (input_location, NEGATE_EXPR,
10703 : integer_type_node,
10704 : integer_one_node),
10705 : integer_one_node);
10706 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10707 :
10708 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10709 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10710 :
10711 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10712 576 : }
10713 :
10714 :
10715 : /* Generate code for IEEE_CLASS. */
10716 :
10717 : static void
10718 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10719 : {
10720 648 : tree arg, c, t1, t2, t3, t4;
10721 :
10722 : /* Convert arg, evaluate it only once. */
10723 648 : conv_ieee_function_args (se, expr, &arg, 1);
10724 648 : arg = gfc_evaluate_now (arg, &se->pre);
10725 :
10726 648 : c = build_call_expr_loc (input_location,
10727 : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10728 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10729 : build_int_cst (integer_type_node,
10730 : IEEE_POSITIVE_INF),
10731 : build_int_cst (integer_type_node,
10732 : IEEE_POSITIVE_NORMAL),
10733 : build_int_cst (integer_type_node,
10734 : IEEE_POSITIVE_DENORMAL),
10735 : build_int_cst (integer_type_node,
10736 : IEEE_POSITIVE_ZERO),
10737 : arg);
10738 648 : c = gfc_evaluate_now (c, &se->pre);
10739 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10740 : c, build_int_cst (integer_type_node,
10741 : IEEE_QUIET_NAN));
10742 648 : t2 = build_call_expr_loc (input_location,
10743 : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10744 : arg);
10745 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10746 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10747 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10748 : logical_type_node, t1, t2);
10749 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10750 : c, build_int_cst (integer_type_node,
10751 : IEEE_POSITIVE_ZERO));
10752 648 : t4 = build_call_expr_loc (input_location,
10753 : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10754 : arg);
10755 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10756 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10757 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10758 : logical_type_node, t3, t4);
10759 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10760 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10761 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10762 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10763 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10764 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10765 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10766 648 : build_int_cst (TREE_TYPE (c), s), c);
10767 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10768 : t3, t4, c);
10769 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10770 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10771 : t3);
10772 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10773 : /* Perform a quick sanity check that the return type is
10774 : IEEE_CLASS_TYPE derived type defined in
10775 : libgfortran/ieee/ieee_arithmetic.F90
10776 : Primarily check that it is a derived type with a single
10777 : member in it. */
10778 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10779 648 : tree field = NULL_TREE;
10780 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10781 648 : if (TREE_CODE (f) == FIELD_DECL)
10782 : {
10783 648 : gcc_assert (field == NULL_TREE);
10784 : field = f;
10785 : }
10786 648 : gcc_assert (field);
10787 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10788 648 : se->expr = build_constructor_single (type, field, t1);
10789 648 : }
10790 :
10791 :
10792 : /* Generate code for IEEE_VALUE. */
10793 :
10794 : static void
10795 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10796 : {
10797 1111 : tree args[2], arg, ret, tmp;
10798 1111 : stmtblock_t body;
10799 :
10800 : /* Convert args, evaluate the second one only once. */
10801 1111 : conv_ieee_function_args (se, expr, args, 2);
10802 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10803 :
10804 1111 : tree type = TREE_TYPE (arg);
10805 : /* Perform a quick sanity check that the second argument's type is
10806 : IEEE_CLASS_TYPE derived type defined in
10807 : libgfortran/ieee/ieee_arithmetic.F90
10808 : Primarily check that it is a derived type with a single
10809 : member in it. */
10810 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10811 1111 : tree field = NULL_TREE;
10812 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10813 1111 : if (TREE_CODE (f) == FIELD_DECL)
10814 : {
10815 1111 : gcc_assert (field == NULL_TREE);
10816 : field = f;
10817 : }
10818 1111 : gcc_assert (field);
10819 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10820 : arg, field, NULL_TREE);
10821 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10822 :
10823 1111 : type = gfc_typenode_for_spec (&expr->ts);
10824 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10825 1111 : ret = gfc_create_var (type, NULL);
10826 :
10827 1111 : gfc_init_block (&body);
10828 :
10829 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10830 12221 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10831 : {
10832 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10833 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10834 11110 : tmp = build_case_label (low, low, label);
10835 11110 : gfc_add_expr_to_block (&body, tmp);
10836 :
10837 11110 : REAL_VALUE_TYPE real;
10838 11110 : int k;
10839 11110 : switch (c)
10840 : {
10841 1111 : case IEEE_SIGNALING_NAN:
10842 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10843 1111 : break;
10844 1111 : case IEEE_QUIET_NAN:
10845 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10846 1111 : break;
10847 1111 : case IEEE_NEGATIVE_INF:
10848 1111 : real_inf (&real);
10849 1111 : real = real_value_negate (&real);
10850 1111 : break;
10851 1111 : case IEEE_NEGATIVE_NORMAL:
10852 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10853 1111 : break;
10854 1111 : case IEEE_NEGATIVE_DENORMAL:
10855 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10856 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10857 : type, GFC_RND_MODE);
10858 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10859 1111 : real = real_value_negate (&real);
10860 1111 : break;
10861 1111 : case IEEE_NEGATIVE_ZERO:
10862 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10863 1111 : real = real_value_negate (&real);
10864 1111 : break;
10865 1111 : case IEEE_POSITIVE_ZERO:
10866 : /* Make this also the default: label. The other possibility
10867 : would be to add a separate default: label followed by
10868 : __builtin_unreachable (). */
10869 1111 : label = gfc_build_label_decl (NULL_TREE);
10870 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10871 1111 : gfc_add_expr_to_block (&body, tmp);
10872 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10873 1111 : break;
10874 1111 : case IEEE_POSITIVE_DENORMAL:
10875 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10876 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10877 : type, GFC_RND_MODE);
10878 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10879 1111 : break;
10880 1111 : case IEEE_POSITIVE_NORMAL:
10881 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10882 1111 : break;
10883 1111 : case IEEE_POSITIVE_INF:
10884 1111 : real_inf (&real);
10885 1111 : break;
10886 : default:
10887 : gcc_unreachable ();
10888 : }
10889 :
10890 11110 : tree val = build_real (type, real);
10891 11110 : gfc_add_modify (&body, ret, val);
10892 :
10893 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10894 11110 : gfc_add_expr_to_block (&body, tmp);
10895 : }
10896 :
10897 1111 : tmp = gfc_finish_block (&body);
10898 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10899 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10900 :
10901 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10902 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10903 :
10904 1111 : se->expr = ret;
10905 1111 : }
10906 :
10907 :
10908 : /* Generate code for IEEE_FMA. */
10909 :
10910 : static void
10911 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10912 : {
10913 120 : tree args[3], decl, call;
10914 120 : int argprec;
10915 :
10916 120 : conv_ieee_function_args (se, expr, args, 3);
10917 :
10918 : /* All three arguments should have the same type. */
10919 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10920 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10921 :
10922 : /* Call the type-generic FMA built-in. */
10923 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10924 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10925 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10926 :
10927 : /* Convert to the final type. */
10928 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10929 120 : }
10930 :
10931 :
10932 : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10933 :
10934 : static void
10935 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10936 : const char *name)
10937 : {
10938 3072 : tree args[2], func;
10939 3072 : built_in_function fn;
10940 :
10941 3072 : conv_ieee_function_args (se, expr, args, 2);
10942 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10943 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10944 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10945 :
10946 3072 : if (startswith (name, "mag"))
10947 : {
10948 : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10949 : fminmag() and fmaxmag(), which do not exist as built-ins.
10950 :
10951 : Following glibc, we emit this:
10952 :
10953 : fminmag (x, y) {
10954 : ax = ABS (x);
10955 : ay = ABS (y);
10956 : if (isless (ax, ay))
10957 : return x;
10958 : else if (isgreater (ax, ay))
10959 : return y;
10960 : else if (ax == ay)
10961 : return x < y ? x : y;
10962 : else if (issignaling (x) || issignaling (y))
10963 : return x + y;
10964 : else
10965 : return isnan (y) ? x : y;
10966 : }
10967 :
10968 : fmaxmag (x, y) {
10969 : ax = ABS (x);
10970 : ay = ABS (y);
10971 : if (isgreater (ax, ay))
10972 : return x;
10973 : else if (isless (ax, ay))
10974 : return y;
10975 : else if (ax == ay)
10976 : return x > y ? x : y;
10977 : else if (issignaling (x) || issignaling (y))
10978 : return x + y;
10979 : else
10980 : return isnan (y) ? x : y;
10981 : }
10982 :
10983 : */
10984 :
10985 1536 : tree abs0, abs1, sig0, sig1;
10986 1536 : tree cond1, cond2, cond3, cond4, cond5;
10987 1536 : tree res;
10988 1536 : tree type = TREE_TYPE (args[0]);
10989 :
10990 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
10991 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10992 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10993 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
10994 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
10995 :
10996 1536 : cond5 = build_call_expr_loc (input_location,
10997 : builtin_decl_explicit (BUILT_IN_ISNAN),
10998 : 1, args[1]);
10999 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
11000 : args[0], args[1]);
11001 :
11002 1536 : sig0 = build_call_expr_loc (input_location,
11003 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11004 : 1, args[0]);
11005 1536 : sig1 = build_call_expr_loc (input_location,
11006 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11007 : 1, args[1]);
11008 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
11009 : logical_type_node, sig0, sig1);
11010 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
11011 : fold_build2_loc (input_location, PLUS_EXPR,
11012 : type, args[0], args[1]),
11013 : res);
11014 :
11015 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11016 : abs0, abs1);
11017 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
11018 : fold_build2_loc (input_location,
11019 : max ? MAX_EXPR : MIN_EXPR,
11020 : type, args[0], args[1]),
11021 : res);
11022 :
11023 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
11024 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11025 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
11026 : args[1], res);
11027 :
11028 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
11029 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11030 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
11031 : args[0], res);
11032 :
11033 1536 : se->expr = res;
11034 : }
11035 : else
11036 : {
11037 : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
11038 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
11039 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
11040 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
11041 : }
11042 3072 : }
11043 :
11044 :
11045 : /* Generate code for comparison functions IEEE_QUIET_* and
11046 : IEEE_SIGNALING_*. */
11047 :
11048 : static void
11049 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
11050 : const char *name)
11051 : {
11052 3888 : tree args[2];
11053 3888 : tree arg1, arg2, res;
11054 :
11055 : /* Evaluate arguments only once. */
11056 3888 : conv_ieee_function_args (se, expr, args, 2);
11057 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
11058 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
11059 :
11060 3888 : if (startswith (name, "eq"))
11061 : {
11062 648 : if (signaling)
11063 324 : res = build_call_expr_loc (input_location,
11064 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11065 : 2, arg1, arg2);
11066 : else
11067 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11068 : arg1, arg2);
11069 : }
11070 3240 : else if (startswith (name, "ne"))
11071 : {
11072 648 : if (signaling)
11073 : {
11074 324 : res = build_call_expr_loc (input_location,
11075 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11076 : 2, arg1, arg2);
11077 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
11078 : logical_type_node, res);
11079 : }
11080 : else
11081 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11082 : arg1, arg2);
11083 : }
11084 2592 : else if (startswith (name, "ge"))
11085 : {
11086 648 : if (signaling)
11087 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11088 : arg1, arg2);
11089 : else
11090 324 : res = build_call_expr_loc (input_location,
11091 : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
11092 : 2, arg1, arg2);
11093 : }
11094 1944 : else if (startswith (name, "gt"))
11095 : {
11096 648 : if (signaling)
11097 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
11098 : arg1, arg2);
11099 : else
11100 324 : res = build_call_expr_loc (input_location,
11101 : builtin_decl_explicit (BUILT_IN_ISGREATER),
11102 : 2, arg1, arg2);
11103 : }
11104 1296 : else if (startswith (name, "le"))
11105 : {
11106 648 : if (signaling)
11107 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
11108 : arg1, arg2);
11109 : else
11110 324 : res = build_call_expr_loc (input_location,
11111 : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
11112 : 2, arg1, arg2);
11113 : }
11114 648 : else if (startswith (name, "lt"))
11115 : {
11116 648 : if (signaling)
11117 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11118 : arg1, arg2);
11119 : else
11120 324 : res = build_call_expr_loc (input_location,
11121 : builtin_decl_explicit (BUILT_IN_ISLESS),
11122 : 2, arg1, arg2);
11123 : }
11124 : else
11125 0 : gcc_unreachable ();
11126 :
11127 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
11128 3888 : }
11129 :
11130 :
11131 : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
11132 : module. */
11133 :
11134 : bool
11135 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
11136 : {
11137 13939 : const char *name = expr->value.function.name;
11138 :
11139 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
11140 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
11141 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
11142 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
11143 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
11144 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
11145 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
11146 624 : conv_intrinsic_ieee_signbit (se, expr);
11147 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
11148 312 : conv_intrinsic_ieee_is_normal (se, expr);
11149 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
11150 312 : conv_intrinsic_ieee_is_negative (se, expr);
11151 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
11152 576 : conv_intrinsic_ieee_copy_sign (se, expr);
11153 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
11154 228 : conv_intrinsic_ieee_scalb (se, expr);
11155 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
11156 180 : conv_intrinsic_ieee_next_after (se, expr);
11157 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
11158 84 : conv_intrinsic_ieee_rem (se, expr);
11159 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
11160 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
11161 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
11162 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
11163 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
11164 648 : conv_intrinsic_ieee_class (se, expr);
11165 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
11166 1111 : conv_intrinsic_ieee_value (se, expr);
11167 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
11168 120 : conv_intrinsic_ieee_fma (se, expr);
11169 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
11170 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
11171 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
11172 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
11173 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
11174 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
11175 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
11176 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
11177 : else
11178 : /* It is not among the functions we translate directly. We return
11179 : false, so a library function call is emitted. */
11180 : return false;
11181 :
11182 : return true;
11183 : }
11184 :
11185 :
11186 : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11187 :
11188 : static void
11189 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11190 : {
11191 16 : tree arg, res, restype;
11192 :
11193 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11194 16 : arg = fold_convert (size_type_node, arg);
11195 16 : res = build_call_expr_loc (input_location,
11196 : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11197 16 : restype = gfc_typenode_for_spec (&expr->ts);
11198 16 : se->expr = fold_convert (restype, res);
11199 16 : }
11200 :
11201 :
11202 : /* Generate code for an intrinsic function. Some map directly to library
11203 : calls, others get special handling. In some cases the name of the function
11204 : used depends on the type specifiers. */
11205 :
11206 : void
11207 264656 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11208 : {
11209 264656 : const char *name;
11210 264656 : int lib, kind;
11211 264656 : tree fndecl;
11212 :
11213 264656 : name = &expr->value.function.name[2];
11214 :
11215 264656 : if (expr->rank > 0)
11216 : {
11217 50388 : lib = gfc_is_intrinsic_libcall (expr);
11218 50388 : if (lib != 0)
11219 : {
11220 19200 : if (lib == 1)
11221 11798 : se->ignore_optional = 1;
11222 :
11223 19200 : switch (expr->value.function.isym->id)
11224 : {
11225 5843 : case GFC_ISYM_EOSHIFT:
11226 5843 : case GFC_ISYM_PACK:
11227 5843 : case GFC_ISYM_RESHAPE:
11228 5843 : case GFC_ISYM_REDUCE:
11229 : /* For all of those the first argument specifies the type and the
11230 : third is optional. */
11231 5843 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11232 5843 : break;
11233 :
11234 1116 : case GFC_ISYM_FINDLOC:
11235 1116 : gfc_conv_intrinsic_findloc (se, expr);
11236 1116 : break;
11237 :
11238 2935 : case GFC_ISYM_MINLOC:
11239 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11240 2935 : break;
11241 :
11242 2439 : case GFC_ISYM_MAXLOC:
11243 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11244 2439 : break;
11245 :
11246 6867 : default:
11247 6867 : gfc_conv_intrinsic_funcall (se, expr);
11248 6867 : break;
11249 : }
11250 :
11251 19200 : return;
11252 : }
11253 : }
11254 :
11255 245456 : switch (expr->value.function.isym->id)
11256 : {
11257 0 : case GFC_ISYM_NONE:
11258 0 : gcc_unreachable ();
11259 :
11260 529 : case GFC_ISYM_REPEAT:
11261 529 : gfc_conv_intrinsic_repeat (se, expr);
11262 529 : break;
11263 :
11264 578 : case GFC_ISYM_TRIM:
11265 578 : gfc_conv_intrinsic_trim (se, expr);
11266 578 : break;
11267 :
11268 42 : case GFC_ISYM_SC_KIND:
11269 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11270 42 : break;
11271 :
11272 45 : case GFC_ISYM_SI_KIND:
11273 45 : gfc_conv_intrinsic_si_kind (se, expr);
11274 45 : break;
11275 :
11276 6 : case GFC_ISYM_SL_KIND:
11277 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11278 6 : break;
11279 :
11280 82 : case GFC_ISYM_SR_KIND:
11281 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11282 82 : break;
11283 :
11284 228 : case GFC_ISYM_EXPONENT:
11285 228 : gfc_conv_intrinsic_exponent (se, expr);
11286 228 : break;
11287 :
11288 316 : case GFC_ISYM_SCAN:
11289 316 : kind = expr->value.function.actual->expr->ts.kind;
11290 316 : if (kind == 1)
11291 250 : fndecl = gfor_fndecl_string_scan;
11292 66 : else if (kind == 4)
11293 66 : fndecl = gfor_fndecl_string_scan_char4;
11294 : else
11295 0 : gcc_unreachable ();
11296 :
11297 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11298 316 : break;
11299 :
11300 94 : case GFC_ISYM_VERIFY:
11301 94 : kind = expr->value.function.actual->expr->ts.kind;
11302 94 : if (kind == 1)
11303 70 : fndecl = gfor_fndecl_string_verify;
11304 24 : else if (kind == 4)
11305 24 : fndecl = gfor_fndecl_string_verify_char4;
11306 : else
11307 0 : gcc_unreachable ();
11308 :
11309 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11310 94 : break;
11311 :
11312 7381 : case GFC_ISYM_ALLOCATED:
11313 7381 : gfc_conv_allocated (se, expr);
11314 7381 : break;
11315 :
11316 9514 : case GFC_ISYM_ASSOCIATED:
11317 9514 : gfc_conv_associated(se, expr);
11318 9514 : break;
11319 :
11320 409 : case GFC_ISYM_SAME_TYPE_AS:
11321 409 : gfc_conv_same_type_as (se, expr);
11322 409 : break;
11323 :
11324 7932 : case GFC_ISYM_ABS:
11325 7932 : gfc_conv_intrinsic_abs (se, expr);
11326 7932 : break;
11327 :
11328 345 : case GFC_ISYM_ADJUSTL:
11329 345 : if (expr->ts.kind == 1)
11330 291 : fndecl = gfor_fndecl_adjustl;
11331 54 : else if (expr->ts.kind == 4)
11332 54 : fndecl = gfor_fndecl_adjustl_char4;
11333 : else
11334 0 : gcc_unreachable ();
11335 :
11336 345 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11337 345 : break;
11338 :
11339 123 : case GFC_ISYM_ADJUSTR:
11340 123 : if (expr->ts.kind == 1)
11341 68 : fndecl = gfor_fndecl_adjustr;
11342 55 : else if (expr->ts.kind == 4)
11343 55 : fndecl = gfor_fndecl_adjustr_char4;
11344 : else
11345 0 : gcc_unreachable ();
11346 :
11347 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11348 123 : break;
11349 :
11350 440 : case GFC_ISYM_AIMAG:
11351 440 : gfc_conv_intrinsic_imagpart (se, expr);
11352 440 : break;
11353 :
11354 146 : case GFC_ISYM_AINT:
11355 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11356 146 : break;
11357 :
11358 420 : case GFC_ISYM_ALL:
11359 420 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11360 420 : break;
11361 :
11362 74 : case GFC_ISYM_ANINT:
11363 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11364 74 : break;
11365 :
11366 90 : case GFC_ISYM_AND:
11367 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11368 90 : break;
11369 :
11370 38077 : case GFC_ISYM_ANY:
11371 38077 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11372 38077 : break;
11373 :
11374 216 : case GFC_ISYM_ACOSD:
11375 216 : case GFC_ISYM_ASIND:
11376 216 : case GFC_ISYM_ATAND:
11377 216 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11378 216 : break;
11379 :
11380 102 : case GFC_ISYM_COTAN:
11381 102 : gfc_conv_intrinsic_cotan (se, expr);
11382 102 : break;
11383 :
11384 108 : case GFC_ISYM_COTAND:
11385 108 : gfc_conv_intrinsic_cotand (se, expr);
11386 108 : break;
11387 :
11388 120 : case GFC_ISYM_ATAN2D:
11389 120 : gfc_conv_intrinsic_atan2d (se, expr);
11390 120 : break;
11391 :
11392 145 : case GFC_ISYM_BTEST:
11393 145 : gfc_conv_intrinsic_btest (se, expr);
11394 145 : break;
11395 :
11396 54 : case GFC_ISYM_BGE:
11397 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11398 54 : break;
11399 :
11400 54 : case GFC_ISYM_BGT:
11401 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11402 54 : break;
11403 :
11404 54 : case GFC_ISYM_BLE:
11405 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11406 54 : break;
11407 :
11408 54 : case GFC_ISYM_BLT:
11409 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11410 54 : break;
11411 :
11412 9794 : case GFC_ISYM_C_ASSOCIATED:
11413 9794 : case GFC_ISYM_C_FUNLOC:
11414 9794 : case GFC_ISYM_C_LOC:
11415 9794 : case GFC_ISYM_F_C_STRING:
11416 9794 : conv_isocbinding_function (se, expr);
11417 9794 : break;
11418 :
11419 2020 : case GFC_ISYM_ACHAR:
11420 2020 : case GFC_ISYM_CHAR:
11421 2020 : gfc_conv_intrinsic_char (se, expr);
11422 2020 : break;
11423 :
11424 40075 : case GFC_ISYM_CONVERSION:
11425 40075 : case GFC_ISYM_DBLE:
11426 40075 : case GFC_ISYM_DFLOAT:
11427 40075 : case GFC_ISYM_FLOAT:
11428 40075 : case GFC_ISYM_LOGICAL:
11429 40075 : case GFC_ISYM_REAL:
11430 40075 : case GFC_ISYM_REALPART:
11431 40075 : case GFC_ISYM_SNGL:
11432 40075 : gfc_conv_intrinsic_conversion (se, expr);
11433 40075 : break;
11434 :
11435 : /* Integer conversions are handled separately to make sure we get the
11436 : correct rounding mode. */
11437 2836 : case GFC_ISYM_INT:
11438 2836 : case GFC_ISYM_INT2:
11439 2836 : case GFC_ISYM_INT8:
11440 2836 : case GFC_ISYM_LONG:
11441 2836 : case GFC_ISYM_UINT:
11442 2836 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11443 2836 : break;
11444 :
11445 162 : case GFC_ISYM_NINT:
11446 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11447 162 : break;
11448 :
11449 16 : case GFC_ISYM_CEILING:
11450 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11451 16 : break;
11452 :
11453 116 : case GFC_ISYM_FLOOR:
11454 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11455 116 : break;
11456 :
11457 3242 : case GFC_ISYM_MOD:
11458 3242 : gfc_conv_intrinsic_mod (se, expr, 0);
11459 3242 : break;
11460 :
11461 442 : case GFC_ISYM_MODULO:
11462 442 : gfc_conv_intrinsic_mod (se, expr, 1);
11463 442 : break;
11464 :
11465 1006 : case GFC_ISYM_CAF_GET:
11466 1006 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11467 1006 : break;
11468 :
11469 167 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11470 167 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11471 167 : break;
11472 :
11473 485 : case GFC_ISYM_CMPLX:
11474 485 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11475 485 : break;
11476 :
11477 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11478 10 : gfc_conv_intrinsic_iargc (se, expr);
11479 10 : break;
11480 :
11481 6 : case GFC_ISYM_COMPLEX:
11482 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11483 6 : break;
11484 :
11485 257 : case GFC_ISYM_CONJG:
11486 257 : gfc_conv_intrinsic_conjg (se, expr);
11487 257 : break;
11488 :
11489 4 : case GFC_ISYM_COSHAPE:
11490 4 : conv_intrinsic_cobound (se, expr);
11491 4 : break;
11492 :
11493 143 : case GFC_ISYM_COUNT:
11494 143 : gfc_conv_intrinsic_count (se, expr);
11495 143 : break;
11496 :
11497 0 : case GFC_ISYM_CTIME:
11498 0 : gfc_conv_intrinsic_ctime (se, expr);
11499 0 : break;
11500 :
11501 96 : case GFC_ISYM_DIM:
11502 96 : gfc_conv_intrinsic_dim (se, expr);
11503 96 : break;
11504 :
11505 113 : case GFC_ISYM_DOT_PRODUCT:
11506 113 : gfc_conv_intrinsic_dot_product (se, expr);
11507 113 : break;
11508 :
11509 13 : case GFC_ISYM_DPROD:
11510 13 : gfc_conv_intrinsic_dprod (se, expr);
11511 13 : break;
11512 :
11513 66 : case GFC_ISYM_DSHIFTL:
11514 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11515 66 : break;
11516 :
11517 66 : case GFC_ISYM_DSHIFTR:
11518 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11519 66 : break;
11520 :
11521 0 : case GFC_ISYM_FDATE:
11522 0 : gfc_conv_intrinsic_fdate (se, expr);
11523 0 : break;
11524 :
11525 60 : case GFC_ISYM_FRACTION:
11526 60 : gfc_conv_intrinsic_fraction (se, expr);
11527 60 : break;
11528 :
11529 24 : case GFC_ISYM_IALL:
11530 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11531 24 : break;
11532 :
11533 606 : case GFC_ISYM_IAND:
11534 606 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11535 606 : break;
11536 :
11537 12 : case GFC_ISYM_IANY:
11538 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11539 12 : break;
11540 :
11541 168 : case GFC_ISYM_IBCLR:
11542 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11543 168 : break;
11544 :
11545 27 : case GFC_ISYM_IBITS:
11546 27 : gfc_conv_intrinsic_ibits (se, expr);
11547 27 : break;
11548 :
11549 138 : case GFC_ISYM_IBSET:
11550 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11551 138 : break;
11552 :
11553 2033 : case GFC_ISYM_IACHAR:
11554 2033 : case GFC_ISYM_ICHAR:
11555 : /* We assume ASCII character sequence. */
11556 2033 : gfc_conv_intrinsic_ichar (se, expr);
11557 2033 : break;
11558 :
11559 2 : case GFC_ISYM_IARGC:
11560 2 : gfc_conv_intrinsic_iargc (se, expr);
11561 2 : break;
11562 :
11563 694 : case GFC_ISYM_IEOR:
11564 694 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11565 694 : break;
11566 :
11567 341 : case GFC_ISYM_INDEX:
11568 341 : kind = expr->value.function.actual->expr->ts.kind;
11569 341 : if (kind == 1)
11570 275 : fndecl = gfor_fndecl_string_index;
11571 66 : else if (kind == 4)
11572 66 : fndecl = gfor_fndecl_string_index_char4;
11573 : else
11574 0 : gcc_unreachable ();
11575 :
11576 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11577 341 : break;
11578 :
11579 495 : case GFC_ISYM_IOR:
11580 495 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11581 495 : break;
11582 :
11583 12 : case GFC_ISYM_IPARITY:
11584 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11585 12 : break;
11586 :
11587 6 : case GFC_ISYM_IS_IOSTAT_END:
11588 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11589 6 : break;
11590 :
11591 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11592 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11593 18 : break;
11594 :
11595 735 : case GFC_ISYM_IS_CONTIGUOUS:
11596 735 : gfc_conv_intrinsic_is_contiguous (se, expr);
11597 735 : break;
11598 :
11599 432 : case GFC_ISYM_ISNAN:
11600 432 : gfc_conv_intrinsic_isnan (se, expr);
11601 432 : break;
11602 :
11603 8 : case GFC_ISYM_KILL:
11604 8 : conv_intrinsic_kill (se, expr);
11605 8 : break;
11606 :
11607 90 : case GFC_ISYM_LSHIFT:
11608 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11609 90 : break;
11610 :
11611 24 : case GFC_ISYM_RSHIFT:
11612 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11613 24 : break;
11614 :
11615 78 : case GFC_ISYM_SHIFTA:
11616 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11617 78 : break;
11618 :
11619 234 : case GFC_ISYM_SHIFTL:
11620 234 : gfc_conv_intrinsic_shift (se, expr, false, false);
11621 234 : break;
11622 :
11623 66 : case GFC_ISYM_SHIFTR:
11624 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11625 66 : break;
11626 :
11627 318 : case GFC_ISYM_ISHFT:
11628 318 : gfc_conv_intrinsic_ishft (se, expr);
11629 318 : break;
11630 :
11631 658 : case GFC_ISYM_ISHFTC:
11632 658 : gfc_conv_intrinsic_ishftc (se, expr);
11633 658 : break;
11634 :
11635 270 : case GFC_ISYM_LEADZ:
11636 270 : gfc_conv_intrinsic_leadz (se, expr);
11637 270 : break;
11638 :
11639 282 : case GFC_ISYM_TRAILZ:
11640 282 : gfc_conv_intrinsic_trailz (se, expr);
11641 282 : break;
11642 :
11643 103 : case GFC_ISYM_POPCNT:
11644 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11645 103 : break;
11646 :
11647 31 : case GFC_ISYM_POPPAR:
11648 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11649 31 : break;
11650 :
11651 5561 : case GFC_ISYM_LBOUND:
11652 5561 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11653 5561 : break;
11654 :
11655 210 : case GFC_ISYM_LCOBOUND:
11656 210 : conv_intrinsic_cobound (se, expr);
11657 210 : break;
11658 :
11659 744 : case GFC_ISYM_TRANSPOSE:
11660 : /* The scalarizer has already been set up for reversed dimension access
11661 : order ; now we just get the argument value normally. */
11662 744 : gfc_conv_expr (se, expr->value.function.actual->expr);
11663 744 : break;
11664 :
11665 5861 : case GFC_ISYM_LEN:
11666 5861 : gfc_conv_intrinsic_len (se, expr);
11667 5861 : break;
11668 :
11669 2335 : case GFC_ISYM_LEN_TRIM:
11670 2335 : gfc_conv_intrinsic_len_trim (se, expr);
11671 2335 : break;
11672 :
11673 18 : case GFC_ISYM_LGE:
11674 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11675 18 : break;
11676 :
11677 36 : case GFC_ISYM_LGT:
11678 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11679 36 : break;
11680 :
11681 18 : case GFC_ISYM_LLE:
11682 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11683 18 : break;
11684 :
11685 27 : case GFC_ISYM_LLT:
11686 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11687 27 : break;
11688 :
11689 16 : case GFC_ISYM_MALLOC:
11690 16 : gfc_conv_intrinsic_malloc (se, expr);
11691 16 : break;
11692 :
11693 32 : case GFC_ISYM_MASKL:
11694 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11695 32 : break;
11696 :
11697 32 : case GFC_ISYM_MASKR:
11698 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11699 32 : break;
11700 :
11701 1049 : case GFC_ISYM_MAX:
11702 1049 : if (expr->ts.type == BT_CHARACTER)
11703 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11704 : else
11705 911 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11706 : break;
11707 :
11708 6348 : case GFC_ISYM_MAXLOC:
11709 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11710 6348 : break;
11711 :
11712 216 : case GFC_ISYM_FINDLOC:
11713 216 : gfc_conv_intrinsic_findloc (se, expr);
11714 216 : break;
11715 :
11716 1101 : case GFC_ISYM_MAXVAL:
11717 1101 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11718 1101 : break;
11719 :
11720 949 : case GFC_ISYM_MERGE:
11721 949 : gfc_conv_intrinsic_merge (se, expr);
11722 949 : break;
11723 :
11724 42 : case GFC_ISYM_MERGE_BITS:
11725 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11726 42 : break;
11727 :
11728 598 : case GFC_ISYM_MIN:
11729 598 : if (expr->ts.type == BT_CHARACTER)
11730 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11731 : else
11732 454 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11733 : break;
11734 :
11735 7176 : case GFC_ISYM_MINLOC:
11736 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11737 7176 : break;
11738 :
11739 1316 : case GFC_ISYM_MINVAL:
11740 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11741 1316 : break;
11742 :
11743 1595 : case GFC_ISYM_NEAREST:
11744 1595 : gfc_conv_intrinsic_nearest (se, expr);
11745 1595 : break;
11746 :
11747 68 : case GFC_ISYM_NORM2:
11748 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11749 68 : break;
11750 :
11751 230 : case GFC_ISYM_NOT:
11752 230 : gfc_conv_intrinsic_not (se, expr);
11753 230 : break;
11754 :
11755 12 : case GFC_ISYM_OR:
11756 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11757 12 : break;
11758 :
11759 468 : case GFC_ISYM_OUT_OF_RANGE:
11760 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11761 468 : break;
11762 :
11763 36 : case GFC_ISYM_PARITY:
11764 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11765 36 : break;
11766 :
11767 5070 : case GFC_ISYM_PRESENT:
11768 5070 : gfc_conv_intrinsic_present (se, expr);
11769 5070 : break;
11770 :
11771 358 : case GFC_ISYM_PRODUCT:
11772 358 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11773 358 : break;
11774 :
11775 12693 : case GFC_ISYM_RANK:
11776 12693 : gfc_conv_intrinsic_rank (se, expr);
11777 12693 : break;
11778 :
11779 48 : case GFC_ISYM_RRSPACING:
11780 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11781 48 : break;
11782 :
11783 262 : case GFC_ISYM_SET_EXPONENT:
11784 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11785 262 : break;
11786 :
11787 72 : case GFC_ISYM_SCALE:
11788 72 : gfc_conv_intrinsic_scale (se, expr);
11789 72 : break;
11790 :
11791 4940 : case GFC_ISYM_SHAPE:
11792 4940 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11793 4940 : break;
11794 :
11795 423 : case GFC_ISYM_SIGN:
11796 423 : gfc_conv_intrinsic_sign (se, expr);
11797 423 : break;
11798 :
11799 15306 : case GFC_ISYM_SIZE:
11800 15306 : gfc_conv_intrinsic_size (se, expr);
11801 15306 : break;
11802 :
11803 1309 : case GFC_ISYM_SIZEOF:
11804 1309 : case GFC_ISYM_C_SIZEOF:
11805 1309 : gfc_conv_intrinsic_sizeof (se, expr);
11806 1309 : break;
11807 :
11808 840 : case GFC_ISYM_STORAGE_SIZE:
11809 840 : gfc_conv_intrinsic_storage_size (se, expr);
11810 840 : break;
11811 :
11812 70 : case GFC_ISYM_SPACING:
11813 70 : gfc_conv_intrinsic_spacing (se, expr);
11814 70 : break;
11815 :
11816 2302 : case GFC_ISYM_STRIDE:
11817 2302 : conv_intrinsic_stride (se, expr);
11818 2302 : break;
11819 :
11820 2005 : case GFC_ISYM_SUM:
11821 2005 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11822 2005 : break;
11823 :
11824 21 : case GFC_ISYM_TEAM_NUMBER:
11825 21 : conv_intrinsic_team_number (se, expr);
11826 21 : break;
11827 :
11828 4105 : case GFC_ISYM_TRANSFER:
11829 4105 : if (se->ss && se->ss->info->useflags)
11830 : /* Access the previously obtained result. */
11831 281 : gfc_conv_tmp_array_ref (se);
11832 : else
11833 3824 : gfc_conv_intrinsic_transfer (se, expr);
11834 : break;
11835 :
11836 0 : case GFC_ISYM_TTYNAM:
11837 0 : gfc_conv_intrinsic_ttynam (se, expr);
11838 0 : break;
11839 :
11840 5736 : case GFC_ISYM_UBOUND:
11841 5736 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11842 5736 : break;
11843 :
11844 244 : case GFC_ISYM_UCOBOUND:
11845 244 : conv_intrinsic_cobound (se, expr);
11846 244 : break;
11847 :
11848 18 : case GFC_ISYM_XOR:
11849 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11850 18 : break;
11851 :
11852 8860 : case GFC_ISYM_LOC:
11853 8860 : gfc_conv_intrinsic_loc (se, expr);
11854 8860 : break;
11855 :
11856 1506 : case GFC_ISYM_THIS_IMAGE:
11857 : /* For num_images() == 1, handle as LCOBOUND. */
11858 1506 : if (expr->value.function.actual->expr
11859 526 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11860 208 : conv_intrinsic_cobound (se, expr);
11861 : else
11862 1298 : trans_this_image (se, expr);
11863 : break;
11864 :
11865 193 : case GFC_ISYM_IMAGE_INDEX:
11866 193 : trans_image_index (se, expr);
11867 193 : break;
11868 :
11869 25 : case GFC_ISYM_IMAGE_STATUS:
11870 25 : conv_intrinsic_image_status (se, expr);
11871 25 : break;
11872 :
11873 810 : case GFC_ISYM_NUM_IMAGES:
11874 810 : trans_num_images (se, expr);
11875 810 : break;
11876 :
11877 1394 : case GFC_ISYM_ACCESS:
11878 1394 : case GFC_ISYM_CHDIR:
11879 1394 : case GFC_ISYM_CHMOD:
11880 1394 : case GFC_ISYM_DTIME:
11881 1394 : case GFC_ISYM_ETIME:
11882 1394 : case GFC_ISYM_EXTENDS_TYPE_OF:
11883 1394 : case GFC_ISYM_FGET:
11884 1394 : case GFC_ISYM_FGETC:
11885 1394 : case GFC_ISYM_FNUM:
11886 1394 : case GFC_ISYM_FPUT:
11887 1394 : case GFC_ISYM_FPUTC:
11888 1394 : case GFC_ISYM_FSTAT:
11889 1394 : case GFC_ISYM_FTELL:
11890 1394 : case GFC_ISYM_GETCWD:
11891 1394 : case GFC_ISYM_GETGID:
11892 1394 : case GFC_ISYM_GETPID:
11893 1394 : case GFC_ISYM_GETUID:
11894 1394 : case GFC_ISYM_GET_TEAM:
11895 1394 : case GFC_ISYM_HOSTNM:
11896 1394 : case GFC_ISYM_IERRNO:
11897 1394 : case GFC_ISYM_IRAND:
11898 1394 : case GFC_ISYM_ISATTY:
11899 1394 : case GFC_ISYM_JN2:
11900 1394 : case GFC_ISYM_LINK:
11901 1394 : case GFC_ISYM_LSTAT:
11902 1394 : case GFC_ISYM_MATMUL:
11903 1394 : case GFC_ISYM_MCLOCK:
11904 1394 : case GFC_ISYM_MCLOCK8:
11905 1394 : case GFC_ISYM_RAND:
11906 1394 : case GFC_ISYM_REDUCE:
11907 1394 : case GFC_ISYM_RENAME:
11908 1394 : case GFC_ISYM_SECOND:
11909 1394 : case GFC_ISYM_SECNDS:
11910 1394 : case GFC_ISYM_SIGNAL:
11911 1394 : case GFC_ISYM_STAT:
11912 1394 : case GFC_ISYM_SYMLNK:
11913 1394 : case GFC_ISYM_SYSTEM:
11914 1394 : case GFC_ISYM_TIME:
11915 1394 : case GFC_ISYM_TIME8:
11916 1394 : case GFC_ISYM_UMASK:
11917 1394 : case GFC_ISYM_UNLINK:
11918 1394 : case GFC_ISYM_YN2:
11919 1394 : gfc_conv_intrinsic_funcall (se, expr);
11920 1394 : break;
11921 :
11922 0 : case GFC_ISYM_EOSHIFT:
11923 0 : case GFC_ISYM_PACK:
11924 0 : case GFC_ISYM_RESHAPE:
11925 : /* For those, expr->rank should always be >0 and thus the if above the
11926 : switch should have matched. */
11927 0 : gcc_unreachable ();
11928 3874 : break;
11929 :
11930 3874 : default:
11931 3874 : gfc_conv_intrinsic_lib_function (se, expr);
11932 3874 : break;
11933 : }
11934 : }
11935 :
11936 :
11937 : static gfc_ss *
11938 1560 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11939 : {
11940 1560 : gfc_ss *arg_ss, *tmp_ss;
11941 1560 : gfc_actual_arglist *arg;
11942 :
11943 1560 : arg = expr->value.function.actual;
11944 :
11945 1560 : gcc_assert (arg->expr);
11946 :
11947 1560 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11948 1560 : gcc_assert (arg_ss != gfc_ss_terminator);
11949 :
11950 : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11951 : {
11952 1665 : if (tmp_ss->info->type != GFC_SS_SCALAR
11953 : && tmp_ss->info->type != GFC_SS_REFERENCE)
11954 : {
11955 1628 : gcc_assert (tmp_ss->dimen == 2);
11956 :
11957 : /* We just invert dimensions. */
11958 1628 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11959 : }
11960 :
11961 : /* Stop when tmp_ss points to the last valid element of the chain... */
11962 1665 : if (tmp_ss->next == gfc_ss_terminator)
11963 : break;
11964 : }
11965 :
11966 : /* ... so that we can attach the rest of the chain to it. */
11967 1560 : tmp_ss->next = ss;
11968 :
11969 1560 : return arg_ss;
11970 : }
11971 :
11972 :
11973 : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11974 : This has the side effect of reversing the nested list, so there is no
11975 : need to call gfc_reverse_ss on it (the given list is assumed not to be
11976 : reversed yet). */
11977 :
11978 : static gfc_ss *
11979 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
11980 : {
11981 3371 : int ss_dim, i;
11982 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11983 3371 : gfc_loopinfo *new_loop;
11984 :
11985 3371 : gcc_assert (ss != gfc_ss_terminator);
11986 :
11987 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
11988 : {
11989 4747 : new_ss = gfc_get_ss ();
11990 4747 : new_ss->next = prev_ss;
11991 4747 : new_ss->parent = ss;
11992 4747 : new_ss->info = ss->info;
11993 4747 : new_ss->info->refcount++;
11994 4747 : if (ss->dimen != 0)
11995 : {
11996 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
11997 : && ss->info->type != GFC_SS_REFERENCE);
11998 :
11999 4684 : new_ss->dimen = 1;
12000 4684 : new_ss->dim[0] = ss->dim[dim];
12001 :
12002 4684 : gcc_assert (dim < ss->dimen);
12003 :
12004 4684 : ss_dim = --ss->dimen;
12005 10430 : for (i = dim; i < ss_dim; i++)
12006 5746 : ss->dim[i] = ss->dim[i + 1];
12007 :
12008 4684 : ss->dim[ss_dim] = 0;
12009 : }
12010 4747 : prev_ss = new_ss;
12011 :
12012 4747 : if (ss->nested_ss)
12013 : {
12014 81 : ss->nested_ss->parent = new_ss;
12015 81 : new_ss->nested_ss = ss->nested_ss;
12016 : }
12017 4747 : ss->nested_ss = new_ss;
12018 : }
12019 :
12020 3371 : new_loop = gfc_get_loopinfo ();
12021 3371 : gfc_init_loopinfo (new_loop);
12022 :
12023 3371 : gcc_assert (prev_ss != NULL);
12024 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
12025 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
12026 3371 : return new_ss->parent;
12027 : }
12028 :
12029 :
12030 : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
12031 : is to be inlined. */
12032 :
12033 : static gfc_ss *
12034 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
12035 : {
12036 575 : gfc_ss *tmp_ss, *tail, *array_ss;
12037 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
12038 575 : int sum_dim;
12039 575 : bool scalar_mask = false;
12040 :
12041 : /* The rank of the result will be determined later. */
12042 575 : arg1 = expr->value.function.actual;
12043 575 : arg2 = arg1->next;
12044 575 : arg3 = arg2->next;
12045 575 : gcc_assert (arg3 != NULL);
12046 :
12047 575 : if (expr->rank == 0)
12048 : return ss;
12049 :
12050 575 : tmp_ss = gfc_ss_terminator;
12051 :
12052 575 : if (arg3->expr)
12053 : {
12054 118 : gfc_ss *mask_ss;
12055 :
12056 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
12057 118 : if (mask_ss == tmp_ss)
12058 34 : scalar_mask = 1;
12059 :
12060 : tmp_ss = mask_ss;
12061 : }
12062 :
12063 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
12064 575 : gcc_assert (array_ss != tmp_ss);
12065 :
12066 : /* Odd thing: If the mask is scalar, it is used by the frontend after
12067 : the array (to make an if around the nested loop). Thus it shall
12068 : be after array_ss once the gfc_ss list is reversed. */
12069 575 : if (scalar_mask)
12070 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
12071 : else
12072 : tmp_ss = array_ss;
12073 :
12074 : /* "Hide" the dimension on which we will sum in the first arg's scalarization
12075 : chain. */
12076 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
12077 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
12078 575 : tail->next = ss;
12079 :
12080 575 : return tmp_ss;
12081 : }
12082 :
12083 :
12084 : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
12085 : function is to be inlined. */
12086 :
12087 : static gfc_ss *
12088 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
12089 : {
12090 6085 : if (expr->rank == 0)
12091 : return ss;
12092 :
12093 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12094 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
12095 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
12096 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
12097 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
12098 :
12099 6085 : gfc_expr *array = array_arg->expr;
12100 6085 : gfc_expr *dim = dim_arg->expr;
12101 6085 : gfc_expr *mask = mask_arg->expr;
12102 6085 : gfc_expr *back = back_arg->expr;
12103 :
12104 6085 : if (dim == nullptr)
12105 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12106 :
12107 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
12108 :
12109 2796 : bool scalar_mask = false;
12110 2796 : if (mask)
12111 : {
12112 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
12113 1866 : if (mask_ss == tmp_ss)
12114 : scalar_mask = true;
12115 1174 : else if (maybe_absent_optional_variable (mask))
12116 20 : mask_ss->info->can_be_null_ref = true;
12117 :
12118 : tmp_ss = mask_ss;
12119 : }
12120 :
12121 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
12122 2796 : gcc_assert (array_ss != tmp_ss);
12123 :
12124 2796 : tmp_ss = array_ss;
12125 :
12126 : /* Move the dimension on which we will sum to a separate nested scalarization
12127 : chain, "hiding" that dimension from the outer scalarization. */
12128 2796 : int dim_val = mpz_get_si (dim->value.integer);
12129 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
12130 :
12131 2796 : if (back && array->rank > 1)
12132 : {
12133 : /* If there are nested scalarization loops, include BACK in the
12134 : scalarization chains to avoid evaluating it multiple times in a loop.
12135 : Otherwise, prefer to handle it outside of scalarization. */
12136 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
12137 2796 : back_ss->info->type = GFC_SS_REFERENCE;
12138 2796 : if (maybe_absent_optional_variable (back))
12139 16 : back_ss->info->can_be_null_ref = true;
12140 :
12141 2796 : tail->next = back_ss;
12142 2796 : }
12143 : else
12144 0 : tail->next = ss;
12145 :
12146 2796 : if (scalar_mask)
12147 : {
12148 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
12149 : /* MASK can be a forwarded optional argument, so make the necessary setup
12150 : to avoid the scalarizer generating any unguarded pointer dereference in
12151 : that case. */
12152 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
12153 692 : if (maybe_absent_optional_variable (mask))
12154 4 : tmp_ss->info->can_be_null_ref = true;
12155 : }
12156 :
12157 : return tmp_ss;
12158 : }
12159 :
12160 :
12161 : static gfc_ss *
12162 8220 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
12163 : {
12164 :
12165 8220 : switch (expr->value.function.isym->id)
12166 : {
12167 575 : case GFC_ISYM_PRODUCT:
12168 575 : case GFC_ISYM_SUM:
12169 575 : return walk_inline_intrinsic_arith (ss, expr);
12170 :
12171 1560 : case GFC_ISYM_TRANSPOSE:
12172 1560 : return walk_inline_intrinsic_transpose (ss, expr);
12173 :
12174 6085 : case GFC_ISYM_MAXLOC:
12175 6085 : case GFC_ISYM_MINLOC:
12176 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
12177 :
12178 0 : default:
12179 0 : gcc_unreachable ();
12180 : }
12181 : gcc_unreachable ();
12182 : }
12183 :
12184 :
12185 : /* This generates code to execute before entering the scalarization loop.
12186 : Currently does nothing. */
12187 :
12188 : void
12189 11533 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12190 : {
12191 11533 : switch (ss->info->expr->value.function.isym->id)
12192 : {
12193 11533 : case GFC_ISYM_UBOUND:
12194 11533 : case GFC_ISYM_LBOUND:
12195 11533 : case GFC_ISYM_COSHAPE:
12196 11533 : case GFC_ISYM_UCOBOUND:
12197 11533 : case GFC_ISYM_LCOBOUND:
12198 11533 : case GFC_ISYM_MAXLOC:
12199 11533 : case GFC_ISYM_MINLOC:
12200 11533 : case GFC_ISYM_THIS_IMAGE:
12201 11533 : case GFC_ISYM_SHAPE:
12202 11533 : break;
12203 :
12204 0 : default:
12205 0 : gcc_unreachable ();
12206 : }
12207 11533 : }
12208 :
12209 :
12210 : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12211 : one parameter are expanded into code inside the scalarization loop. */
12212 :
12213 : static gfc_ss *
12214 10089 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12215 : {
12216 10089 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12217 438 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12218 :
12219 : /* The two argument version returns a scalar. */
12220 10089 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12221 3522 : && expr->value.function.isym->id != GFC_ISYM_COSHAPE
12222 3518 : && expr->value.function.actual->next->expr)
12223 : return ss;
12224 :
12225 10089 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12226 : }
12227 :
12228 :
12229 : /* Walk an intrinsic array libcall. */
12230 :
12231 : static gfc_ss *
12232 14494 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12233 : {
12234 14494 : gcc_assert (expr->rank > 0);
12235 14494 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12236 : }
12237 :
12238 :
12239 : /* Return whether the function call expression EXPR will be expanded
12240 : inline by gfc_conv_intrinsic_function. */
12241 :
12242 : bool
12243 301569 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12244 : {
12245 301569 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12246 301569 : gfc_expr *maskexpr;
12247 :
12248 301569 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12249 301569 : if (!isym)
12250 : return false;
12251 :
12252 301527 : switch (isym->id)
12253 : {
12254 5106 : case GFC_ISYM_PRODUCT:
12255 5106 : case GFC_ISYM_SUM:
12256 : /* Disable inline expansion if code size matters. */
12257 5106 : if (optimize_size)
12258 : return false;
12259 :
12260 4251 : args = expr->value.function.actual;
12261 4251 : dim_arg = args->next;
12262 :
12263 : /* We need to be able to subset the SUM argument at compile-time. */
12264 4251 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12265 : return false;
12266 :
12267 : /* FIXME: If MASK is optional for a more than two-dimensional
12268 : argument, the scalarizer gets confused if the mask is
12269 : absent. See PR 82995. For now, fall back to the library
12270 : function. */
12271 :
12272 3639 : mask_arg = dim_arg->next;
12273 3639 : maskexpr = mask_arg->expr;
12274 :
12275 3639 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12276 276 : && maskexpr->symtree->n.sym->attr.dummy
12277 48 : && maskexpr->symtree->n.sym->attr.optional)
12278 : return false;
12279 :
12280 : return true;
12281 :
12282 : case GFC_ISYM_TRANSPOSE:
12283 : return true;
12284 :
12285 57188 : case GFC_ISYM_MINLOC:
12286 57188 : case GFC_ISYM_MAXLOC:
12287 57188 : {
12288 57188 : if ((isym->id == GFC_ISYM_MINLOC
12289 30521 : && (flag_inline_intrinsics
12290 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12291 46611 : || (isym->id == GFC_ISYM_MAXLOC
12292 26667 : && (flag_inline_intrinsics
12293 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12294 : return false;
12295 :
12296 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12297 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12298 :
12299 37638 : gfc_expr *array = array_arg->expr;
12300 37638 : gfc_expr *dim = dim_arg->expr;
12301 :
12302 37638 : if (!(array->ts.type == BT_INTEGER
12303 : || array->ts.type == BT_REAL))
12304 : return false;
12305 :
12306 34658 : if (array->rank == 1)
12307 : return true;
12308 :
12309 20711 : if (dim != nullptr
12310 13372 : && dim->expr_type != EXPR_CONSTANT)
12311 : return false;
12312 :
12313 : return true;
12314 : }
12315 :
12316 : default:
12317 : return false;
12318 : }
12319 : }
12320 :
12321 :
12322 : /* Returns nonzero if the specified intrinsic function call maps directly to
12323 : an external library call. Should only be used for functions that return
12324 : arrays. */
12325 :
12326 : int
12327 87767 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12328 : {
12329 87767 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12330 87767 : gcc_assert (expr->rank > 0);
12331 :
12332 87767 : if (gfc_inline_intrinsic_function_p (expr))
12333 : return 0;
12334 :
12335 73186 : switch (expr->value.function.isym->id)
12336 : {
12337 : case GFC_ISYM_ALL:
12338 : case GFC_ISYM_ANY:
12339 : case GFC_ISYM_COUNT:
12340 : case GFC_ISYM_FINDLOC:
12341 : case GFC_ISYM_JN2:
12342 : case GFC_ISYM_IANY:
12343 : case GFC_ISYM_IALL:
12344 : case GFC_ISYM_IPARITY:
12345 : case GFC_ISYM_MATMUL:
12346 : case GFC_ISYM_MAXLOC:
12347 : case GFC_ISYM_MAXVAL:
12348 : case GFC_ISYM_MINLOC:
12349 : case GFC_ISYM_MINVAL:
12350 : case GFC_ISYM_NORM2:
12351 : case GFC_ISYM_PARITY:
12352 : case GFC_ISYM_PRODUCT:
12353 : case GFC_ISYM_SUM:
12354 : case GFC_ISYM_SPREAD:
12355 : case GFC_ISYM_YN2:
12356 : /* Ignore absent optional parameters. */
12357 : return 1;
12358 :
12359 15801 : case GFC_ISYM_CSHIFT:
12360 15801 : case GFC_ISYM_EOSHIFT:
12361 15801 : case GFC_ISYM_GET_TEAM:
12362 15801 : case GFC_ISYM_FAILED_IMAGES:
12363 15801 : case GFC_ISYM_STOPPED_IMAGES:
12364 15801 : case GFC_ISYM_PACK:
12365 15801 : case GFC_ISYM_REDUCE:
12366 15801 : case GFC_ISYM_RESHAPE:
12367 15801 : case GFC_ISYM_UNPACK:
12368 : /* Pass absent optional parameters. */
12369 15801 : return 2;
12370 :
12371 : default:
12372 : return 0;
12373 : }
12374 : }
12375 :
12376 : /* Walk an intrinsic function. */
12377 : gfc_ss *
12378 55652 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12379 : gfc_intrinsic_sym * isym)
12380 : {
12381 55652 : gcc_assert (isym);
12382 :
12383 55652 : if (isym->elemental)
12384 18357 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12385 : expr->value.function.isym,
12386 18357 : GFC_SS_SCALAR);
12387 :
12388 37295 : if (expr->rank == 0 && expr->corank == 0)
12389 : return ss;
12390 :
12391 32803 : if (gfc_inline_intrinsic_function_p (expr))
12392 8220 : return walk_inline_intrinsic_function (ss, expr);
12393 :
12394 24583 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12395 13511 : return gfc_walk_intrinsic_libfunc (ss, expr);
12396 :
12397 : /* Special cases. */
12398 11072 : switch (isym->id)
12399 : {
12400 10089 : case GFC_ISYM_COSHAPE:
12401 10089 : case GFC_ISYM_LBOUND:
12402 10089 : case GFC_ISYM_LCOBOUND:
12403 10089 : case GFC_ISYM_UBOUND:
12404 10089 : case GFC_ISYM_UCOBOUND:
12405 10089 : case GFC_ISYM_THIS_IMAGE:
12406 10089 : case GFC_ISYM_SHAPE:
12407 10089 : return gfc_walk_intrinsic_bound (ss, expr);
12408 :
12409 983 : case GFC_ISYM_TRANSFER:
12410 983 : case GFC_ISYM_CAF_GET:
12411 983 : return gfc_walk_intrinsic_libfunc (ss, expr);
12412 :
12413 0 : default:
12414 : /* This probably meant someone forgot to add an intrinsic to the above
12415 : list(s) when they implemented it, or something's gone horribly
12416 : wrong. */
12417 0 : gcc_unreachable ();
12418 : }
12419 : }
12420 :
12421 : static tree
12422 88 : conv_co_collective (gfc_code *code)
12423 : {
12424 88 : gfc_se argse;
12425 88 : stmtblock_t block, post_block;
12426 88 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12427 88 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12428 :
12429 88 : gfc_start_block (&block);
12430 88 : gfc_init_block (&post_block);
12431 :
12432 88 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12433 : {
12434 17 : opr_expr = code->ext.actual->next->expr;
12435 17 : image_idx_expr = code->ext.actual->next->next->expr;
12436 17 : stat_expr = code->ext.actual->next->next->next->expr;
12437 17 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12438 : }
12439 : else
12440 : {
12441 71 : opr_expr = NULL;
12442 71 : image_idx_expr = code->ext.actual->next->expr;
12443 71 : stat_expr = code->ext.actual->next->next->expr;
12444 71 : errmsg_expr = code->ext.actual->next->next->next->expr;
12445 : }
12446 :
12447 : /* stat. */
12448 88 : if (stat_expr)
12449 : {
12450 59 : gfc_init_se (&argse, NULL);
12451 59 : gfc_conv_expr (&argse, stat_expr);
12452 59 : gfc_add_block_to_block (&block, &argse.pre);
12453 59 : gfc_add_block_to_block (&post_block, &argse.post);
12454 59 : stat = argse.expr;
12455 59 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12456 32 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12457 : }
12458 29 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12459 : stat = NULL_TREE;
12460 : else
12461 20 : stat = null_pointer_node;
12462 :
12463 : /* Early exit for GFC_FCOARRAY_SINGLE. */
12464 88 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12465 : {
12466 36 : if (stat != NULL_TREE)
12467 : {
12468 : /* For optional stats, check the pointer is valid before zero'ing. */
12469 27 : if (gfc_expr_attr (stat_expr).optional)
12470 : {
12471 12 : tree tmp;
12472 12 : stmtblock_t ass_block;
12473 12 : gfc_start_block (&ass_block);
12474 12 : gfc_add_modify (&ass_block, stat,
12475 12 : fold_convert (TREE_TYPE (stat),
12476 : integer_zero_node));
12477 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12478 : gfc_build_addr_expr (NULL_TREE, stat),
12479 : null_pointer_node);
12480 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12481 : gfc_finish_block (&ass_block),
12482 : build_empty_stmt (input_location));
12483 12 : gfc_add_expr_to_block (&block, tmp);
12484 : }
12485 : else
12486 15 : gfc_add_modify (&block, stat,
12487 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12488 : }
12489 36 : return gfc_finish_block (&block);
12490 : }
12491 :
12492 5 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12493 52 : ? code->ext.actual->expr->ts.u.derived : NULL;
12494 :
12495 : /* Handle the array. */
12496 52 : gfc_init_se (&argse, NULL);
12497 52 : if (!derived || !derived->attr.alloc_comp
12498 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12499 : {
12500 51 : if (code->ext.actual->expr->rank == 0)
12501 : {
12502 22 : symbol_attribute attr;
12503 22 : gfc_clear_attr (&attr);
12504 22 : gfc_init_se (&argse, NULL);
12505 22 : gfc_conv_expr (&argse, code->ext.actual->expr);
12506 22 : gfc_add_block_to_block (&block, &argse.pre);
12507 22 : gfc_add_block_to_block (&post_block, &argse.post);
12508 22 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12509 22 : array = gfc_build_addr_expr (NULL_TREE, array);
12510 : }
12511 : else
12512 : {
12513 29 : argse.want_pointer = 1;
12514 29 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12515 29 : array = argse.expr;
12516 : }
12517 : }
12518 :
12519 52 : gfc_add_block_to_block (&block, &argse.pre);
12520 52 : gfc_add_block_to_block (&post_block, &argse.post);
12521 :
12522 52 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12523 15 : strlen = argse.string_length;
12524 : else
12525 37 : strlen = integer_zero_node;
12526 :
12527 : /* image_index. */
12528 52 : if (image_idx_expr)
12529 : {
12530 35 : gfc_init_se (&argse, NULL);
12531 35 : gfc_conv_expr (&argse, image_idx_expr);
12532 35 : gfc_add_block_to_block (&block, &argse.pre);
12533 35 : gfc_add_block_to_block (&post_block, &argse.post);
12534 35 : image_index = fold_convert (integer_type_node, argse.expr);
12535 : }
12536 : else
12537 17 : image_index = integer_zero_node;
12538 :
12539 : /* errmsg. */
12540 52 : if (errmsg_expr)
12541 : {
12542 25 : gfc_init_se (&argse, NULL);
12543 25 : gfc_conv_expr (&argse, errmsg_expr);
12544 25 : gfc_add_block_to_block (&block, &argse.pre);
12545 25 : gfc_add_block_to_block (&post_block, &argse.post);
12546 25 : errmsg = argse.expr;
12547 25 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12548 : }
12549 : else
12550 : {
12551 27 : errmsg = null_pointer_node;
12552 27 : errmsg_len = build_zero_cst (size_type_node);
12553 : }
12554 :
12555 : /* Generate the function call. */
12556 52 : switch (code->resolved_isym->id)
12557 : {
12558 20 : case GFC_ISYM_CO_BROADCAST:
12559 20 : fndecl = gfor_fndecl_co_broadcast;
12560 20 : break;
12561 8 : case GFC_ISYM_CO_MAX:
12562 8 : fndecl = gfor_fndecl_co_max;
12563 8 : break;
12564 6 : case GFC_ISYM_CO_MIN:
12565 6 : fndecl = gfor_fndecl_co_min;
12566 6 : break;
12567 12 : case GFC_ISYM_CO_REDUCE:
12568 12 : fndecl = gfor_fndecl_co_reduce;
12569 12 : break;
12570 6 : case GFC_ISYM_CO_SUM:
12571 6 : fndecl = gfor_fndecl_co_sum;
12572 6 : break;
12573 0 : default:
12574 0 : gcc_unreachable ();
12575 : }
12576 :
12577 52 : if (derived && derived->attr.alloc_comp
12578 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12579 : /* The derived type has the attribute 'alloc_comp'. */
12580 : {
12581 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12582 1 : code->ext.actual->expr->rank,
12583 : image_index, stat, errmsg, errmsg_len);
12584 1 : gfc_add_expr_to_block (&block, tmp);
12585 1 : }
12586 : else
12587 : {
12588 51 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12589 45 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12590 25 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12591 : image_index, stat, errmsg, errmsg_len);
12592 26 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12593 14 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12594 : image_index, stat, errmsg,
12595 : strlen, errmsg_len);
12596 : else
12597 : {
12598 12 : tree opr, opr_flags;
12599 :
12600 : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12601 12 : int opr_flag_int;
12602 12 : if (gfc_is_proc_ptr_comp (opr_expr))
12603 : {
12604 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12605 0 : opr_flag_int = sym->attr.dimension
12606 0 : || (sym->ts.type == BT_CHARACTER
12607 0 : && !sym->attr.is_bind_c)
12608 0 : ? GFC_CAF_BYREF : 0;
12609 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12610 0 : && !sym->attr.is_bind_c
12611 0 : ? GFC_CAF_HIDDENLEN : 0;
12612 0 : opr_flag_int |= sym->formal->sym->attr.value
12613 0 : ? GFC_CAF_ARG_VALUE : 0;
12614 : }
12615 : else
12616 : {
12617 12 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12618 12 : ? GFC_CAF_BYREF : 0;
12619 24 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12620 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12621 12 : ? GFC_CAF_HIDDENLEN : 0;
12622 12 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12623 12 : ? GFC_CAF_ARG_VALUE : 0;
12624 : }
12625 12 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12626 12 : gfc_conv_expr (&argse, opr_expr);
12627 12 : opr = argse.expr;
12628 12 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12629 : opr_flags, image_index, stat, errmsg,
12630 : strlen, errmsg_len);
12631 : }
12632 : }
12633 :
12634 52 : gfc_add_expr_to_block (&block, fndecl);
12635 52 : gfc_add_block_to_block (&block, &post_block);
12636 :
12637 52 : return gfc_finish_block (&block);
12638 : }
12639 :
12640 :
12641 : static tree
12642 95 : conv_intrinsic_atomic_op (gfc_code *code)
12643 : {
12644 95 : gfc_se argse;
12645 95 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12646 95 : stmtblock_t block, post_block;
12647 95 : gfc_expr *atom_expr = code->ext.actual->expr;
12648 95 : gfc_expr *stat_expr;
12649 95 : built_in_function fn;
12650 :
12651 95 : if (atom_expr->expr_type == EXPR_FUNCTION
12652 0 : && atom_expr->value.function.isym
12653 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12654 0 : atom_expr = atom_expr->value.function.actual->expr;
12655 :
12656 95 : gfc_start_block (&block);
12657 95 : gfc_init_block (&post_block);
12658 :
12659 95 : gfc_init_se (&argse, NULL);
12660 95 : argse.want_pointer = 1;
12661 95 : gfc_conv_expr (&argse, atom_expr);
12662 95 : gfc_add_block_to_block (&block, &argse.pre);
12663 95 : gfc_add_block_to_block (&post_block, &argse.post);
12664 95 : atom = argse.expr;
12665 :
12666 95 : gfc_init_se (&argse, NULL);
12667 95 : if (flag_coarray == GFC_FCOARRAY_LIB
12668 56 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12669 54 : argse.want_pointer = 1;
12670 95 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12671 95 : gfc_add_block_to_block (&block, &argse.pre);
12672 95 : gfc_add_block_to_block (&post_block, &argse.post);
12673 95 : value = argse.expr;
12674 :
12675 95 : switch (code->resolved_isym->id)
12676 : {
12677 58 : case GFC_ISYM_ATOMIC_ADD:
12678 58 : case GFC_ISYM_ATOMIC_AND:
12679 58 : case GFC_ISYM_ATOMIC_DEF:
12680 58 : case GFC_ISYM_ATOMIC_OR:
12681 58 : case GFC_ISYM_ATOMIC_XOR:
12682 58 : stat_expr = code->ext.actual->next->next->expr;
12683 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12684 34 : old = null_pointer_node;
12685 : break;
12686 37 : default:
12687 37 : gfc_init_se (&argse, NULL);
12688 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
12689 22 : argse.want_pointer = 1;
12690 37 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12691 37 : gfc_add_block_to_block (&block, &argse.pre);
12692 37 : gfc_add_block_to_block (&post_block, &argse.post);
12693 37 : old = argse.expr;
12694 37 : stat_expr = code->ext.actual->next->next->next->expr;
12695 : }
12696 :
12697 : /* STAT= */
12698 95 : if (stat_expr != NULL)
12699 : {
12700 82 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12701 82 : gfc_init_se (&argse, NULL);
12702 82 : if (flag_coarray == GFC_FCOARRAY_LIB)
12703 48 : argse.want_pointer = 1;
12704 82 : gfc_conv_expr_val (&argse, stat_expr);
12705 82 : gfc_add_block_to_block (&block, &argse.pre);
12706 82 : gfc_add_block_to_block (&post_block, &argse.post);
12707 82 : stat = argse.expr;
12708 : }
12709 13 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12710 8 : stat = null_pointer_node;
12711 :
12712 95 : if (flag_coarray == GFC_FCOARRAY_LIB)
12713 : {
12714 56 : tree image_index, caf_decl, offset, token;
12715 56 : int op;
12716 :
12717 56 : switch (code->resolved_isym->id)
12718 : {
12719 : case GFC_ISYM_ATOMIC_ADD:
12720 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12721 : op = (int) GFC_CAF_ATOMIC_ADD;
12722 : break;
12723 12 : case GFC_ISYM_ATOMIC_AND:
12724 12 : case GFC_ISYM_ATOMIC_FETCH_AND:
12725 12 : op = (int) GFC_CAF_ATOMIC_AND;
12726 12 : break;
12727 12 : case GFC_ISYM_ATOMIC_OR:
12728 12 : case GFC_ISYM_ATOMIC_FETCH_OR:
12729 12 : op = (int) GFC_CAF_ATOMIC_OR;
12730 12 : break;
12731 12 : case GFC_ISYM_ATOMIC_XOR:
12732 12 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12733 12 : op = (int) GFC_CAF_ATOMIC_XOR;
12734 12 : break;
12735 11 : case GFC_ISYM_ATOMIC_DEF:
12736 11 : op = 0; /* Unused. */
12737 11 : break;
12738 0 : default:
12739 0 : gcc_unreachable ();
12740 : }
12741 :
12742 56 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12743 56 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12744 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12745 :
12746 56 : if (gfc_is_coindexed (atom_expr))
12747 48 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12748 : else
12749 8 : image_index = integer_zero_node;
12750 :
12751 : /* Ensure VALUE names addressable storage: taking the address of a
12752 : constant is invalid in C, and scalars need a temporary as well. */
12753 56 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12754 : {
12755 42 : tree elem
12756 42 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12757 42 : elem = gfc_trans_force_lval (&block, elem);
12758 42 : value = gfc_build_addr_expr (NULL_TREE, elem);
12759 : }
12760 14 : else if (TREE_CODE (value) == ADDR_EXPR
12761 14 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12762 : {
12763 0 : tree elem
12764 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12765 : build_fold_indirect_ref (value));
12766 0 : elem = gfc_trans_force_lval (&block, elem);
12767 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12768 : }
12769 :
12770 56 : gfc_init_se (&argse, NULL);
12771 56 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12772 : atom_expr);
12773 :
12774 56 : gfc_add_block_to_block (&block, &argse.pre);
12775 56 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12776 11 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12777 : token, offset, image_index, value, stat,
12778 : build_int_cst (integer_type_node,
12779 11 : (int) atom_expr->ts.type),
12780 : build_int_cst (integer_type_node,
12781 11 : (int) atom_expr->ts.kind));
12782 : else
12783 45 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12784 45 : build_int_cst (integer_type_node, op),
12785 : token, offset, image_index, value, old, stat,
12786 : build_int_cst (integer_type_node,
12787 45 : (int) atom_expr->ts.type),
12788 : build_int_cst (integer_type_node,
12789 45 : (int) atom_expr->ts.kind));
12790 :
12791 56 : gfc_add_expr_to_block (&block, tmp);
12792 56 : gfc_add_block_to_block (&block, &argse.post);
12793 56 : gfc_add_block_to_block (&block, &post_block);
12794 56 : return gfc_finish_block (&block);
12795 : }
12796 :
12797 :
12798 39 : switch (code->resolved_isym->id)
12799 : {
12800 : case GFC_ISYM_ATOMIC_ADD:
12801 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12802 : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12803 : break;
12804 8 : case GFC_ISYM_ATOMIC_AND:
12805 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12806 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12807 8 : break;
12808 9 : case GFC_ISYM_ATOMIC_DEF:
12809 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12810 9 : break;
12811 8 : case GFC_ISYM_ATOMIC_OR:
12812 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12813 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12814 8 : break;
12815 8 : case GFC_ISYM_ATOMIC_XOR:
12816 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12817 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12818 8 : break;
12819 0 : default:
12820 0 : gcc_unreachable ();
12821 : }
12822 :
12823 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12824 78 : fn = (built_in_function) ((int) fn
12825 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12826 39 : + 1);
12827 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12828 39 : tmp = builtin_decl_explicit (fn);
12829 :
12830 39 : switch (code->resolved_isym->id)
12831 : {
12832 24 : case GFC_ISYM_ATOMIC_ADD:
12833 24 : case GFC_ISYM_ATOMIC_AND:
12834 24 : case GFC_ISYM_ATOMIC_DEF:
12835 24 : case GFC_ISYM_ATOMIC_OR:
12836 24 : case GFC_ISYM_ATOMIC_XOR:
12837 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12838 : fold_convert (itype, value),
12839 : build_int_cst (NULL, MEMMODEL_RELAXED));
12840 24 : gfc_add_expr_to_block (&block, tmp);
12841 24 : break;
12842 15 : default:
12843 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12844 : fold_convert (itype, value),
12845 : build_int_cst (NULL, MEMMODEL_RELAXED));
12846 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12847 15 : break;
12848 : }
12849 :
12850 39 : if (stat != NULL_TREE)
12851 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12852 39 : gfc_add_block_to_block (&block, &post_block);
12853 39 : return gfc_finish_block (&block);
12854 : }
12855 :
12856 :
12857 : static tree
12858 176 : conv_intrinsic_atomic_ref (gfc_code *code)
12859 : {
12860 176 : gfc_se argse;
12861 176 : tree tmp, atom, value, stat = NULL_TREE;
12862 176 : stmtblock_t block, post_block;
12863 176 : built_in_function fn;
12864 176 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12865 :
12866 176 : if (atom_expr->expr_type == EXPR_FUNCTION
12867 0 : && atom_expr->value.function.isym
12868 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12869 0 : atom_expr = atom_expr->value.function.actual->expr;
12870 :
12871 176 : gfc_start_block (&block);
12872 176 : gfc_init_block (&post_block);
12873 176 : gfc_init_se (&argse, NULL);
12874 176 : argse.want_pointer = 1;
12875 176 : gfc_conv_expr (&argse, atom_expr);
12876 176 : gfc_add_block_to_block (&block, &argse.pre);
12877 176 : gfc_add_block_to_block (&post_block, &argse.post);
12878 176 : atom = argse.expr;
12879 :
12880 176 : gfc_init_se (&argse, NULL);
12881 176 : if (flag_coarray == GFC_FCOARRAY_LIB
12882 115 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12883 109 : argse.want_pointer = 1;
12884 176 : gfc_conv_expr (&argse, code->ext.actual->expr);
12885 176 : gfc_add_block_to_block (&block, &argse.pre);
12886 176 : gfc_add_block_to_block (&post_block, &argse.post);
12887 176 : value = argse.expr;
12888 :
12889 : /* STAT= */
12890 176 : if (code->ext.actual->next->next->expr != NULL)
12891 : {
12892 164 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12893 : == EXPR_VARIABLE);
12894 164 : gfc_init_se (&argse, NULL);
12895 164 : if (flag_coarray == GFC_FCOARRAY_LIB)
12896 108 : argse.want_pointer = 1;
12897 164 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12898 164 : gfc_add_block_to_block (&block, &argse.pre);
12899 164 : gfc_add_block_to_block (&post_block, &argse.post);
12900 164 : stat = argse.expr;
12901 : }
12902 12 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12903 7 : stat = null_pointer_node;
12904 :
12905 176 : if (flag_coarray == GFC_FCOARRAY_LIB)
12906 : {
12907 115 : tree image_index, caf_decl, offset, token;
12908 115 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12909 :
12910 115 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12911 115 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12912 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12913 :
12914 115 : if (gfc_is_coindexed (atom_expr))
12915 103 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12916 : else
12917 12 : image_index = integer_zero_node;
12918 :
12919 115 : gfc_init_se (&argse, NULL);
12920 115 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12921 : atom_expr);
12922 115 : gfc_add_block_to_block (&block, &argse.pre);
12923 :
12924 : /* Different type, need type conversion. */
12925 115 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12926 : {
12927 6 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12928 6 : orig_value = value;
12929 6 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12930 : }
12931 :
12932 115 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12933 : token, offset, image_index, value, stat,
12934 : build_int_cst (integer_type_node,
12935 115 : (int) atom_expr->ts.type),
12936 : build_int_cst (integer_type_node,
12937 115 : (int) atom_expr->ts.kind));
12938 115 : gfc_add_expr_to_block (&block, tmp);
12939 115 : if (vardecl != NULL_TREE)
12940 6 : gfc_add_modify (&block, orig_value,
12941 6 : fold_convert (TREE_TYPE (orig_value), vardecl));
12942 115 : gfc_add_block_to_block (&block, &argse.post);
12943 115 : gfc_add_block_to_block (&block, &post_block);
12944 115 : return gfc_finish_block (&block);
12945 : }
12946 :
12947 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12948 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12949 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12950 61 : + 1);
12951 61 : tmp = builtin_decl_explicit (fn);
12952 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12953 : build_int_cst (integer_type_node,
12954 : MEMMODEL_RELAXED));
12955 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12956 :
12957 61 : if (stat != NULL_TREE)
12958 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12959 61 : gfc_add_block_to_block (&block, &post_block);
12960 61 : return gfc_finish_block (&block);
12961 : }
12962 :
12963 :
12964 : static tree
12965 14 : conv_intrinsic_atomic_cas (gfc_code *code)
12966 : {
12967 14 : gfc_se argse;
12968 14 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12969 14 : stmtblock_t block, post_block;
12970 14 : built_in_function fn;
12971 14 : gfc_expr *atom_expr = code->ext.actual->expr;
12972 :
12973 14 : if (atom_expr->expr_type == EXPR_FUNCTION
12974 0 : && atom_expr->value.function.isym
12975 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12976 0 : atom_expr = atom_expr->value.function.actual->expr;
12977 :
12978 14 : gfc_init_block (&block);
12979 14 : gfc_init_block (&post_block);
12980 14 : gfc_init_se (&argse, NULL);
12981 14 : argse.want_pointer = 1;
12982 14 : gfc_conv_expr (&argse, atom_expr);
12983 14 : atom = argse.expr;
12984 :
12985 14 : gfc_init_se (&argse, NULL);
12986 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12987 8 : argse.want_pointer = 1;
12988 14 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12989 14 : gfc_add_block_to_block (&block, &argse.pre);
12990 14 : gfc_add_block_to_block (&post_block, &argse.post);
12991 14 : old = argse.expr;
12992 :
12993 14 : gfc_init_se (&argse, NULL);
12994 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12995 8 : argse.want_pointer = 1;
12996 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12997 14 : gfc_add_block_to_block (&block, &argse.pre);
12998 14 : gfc_add_block_to_block (&post_block, &argse.post);
12999 14 : comp = argse.expr;
13000 :
13001 14 : gfc_init_se (&argse, NULL);
13002 14 : if (flag_coarray == GFC_FCOARRAY_LIB
13003 8 : && code->ext.actual->next->next->next->expr->ts.kind
13004 8 : == atom_expr->ts.kind)
13005 8 : argse.want_pointer = 1;
13006 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
13007 14 : gfc_add_block_to_block (&block, &argse.pre);
13008 14 : gfc_add_block_to_block (&post_block, &argse.post);
13009 14 : new_val = argse.expr;
13010 :
13011 : /* STAT= */
13012 14 : if (code->ext.actual->next->next->next->next->expr != NULL)
13013 : {
13014 14 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
13015 : == EXPR_VARIABLE);
13016 14 : gfc_init_se (&argse, NULL);
13017 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13018 8 : argse.want_pointer = 1;
13019 14 : gfc_conv_expr_val (&argse,
13020 14 : code->ext.actual->next->next->next->next->expr);
13021 14 : gfc_add_block_to_block (&block, &argse.pre);
13022 14 : gfc_add_block_to_block (&post_block, &argse.post);
13023 14 : stat = argse.expr;
13024 : }
13025 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13026 0 : stat = null_pointer_node;
13027 :
13028 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13029 : {
13030 8 : tree image_index, caf_decl, offset, token;
13031 :
13032 8 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
13033 8 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
13034 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
13035 :
13036 8 : if (gfc_is_coindexed (atom_expr))
13037 8 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
13038 : else
13039 0 : image_index = integer_zero_node;
13040 :
13041 8 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
13042 : {
13043 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
13044 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
13045 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
13046 : }
13047 :
13048 8 : gfc_init_se (&argse, NULL);
13049 8 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
13050 : atom_expr);
13051 8 : gfc_add_block_to_block (&block, &argse.pre);
13052 :
13053 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
13054 : token, offset, image_index, old, comp, new_val,
13055 : stat, build_int_cst (integer_type_node,
13056 8 : (int) atom_expr->ts.type),
13057 : build_int_cst (integer_type_node,
13058 8 : (int) atom_expr->ts.kind));
13059 8 : gfc_add_expr_to_block (&block, tmp);
13060 8 : gfc_add_block_to_block (&block, &argse.post);
13061 8 : gfc_add_block_to_block (&block, &post_block);
13062 8 : return gfc_finish_block (&block);
13063 : }
13064 :
13065 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
13066 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
13067 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
13068 6 : + 1);
13069 6 : tmp = builtin_decl_explicit (fn);
13070 :
13071 6 : gfc_add_modify (&block, old, comp);
13072 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
13073 : gfc_build_addr_expr (NULL, old),
13074 6 : fold_convert (TREE_TYPE (old), new_val),
13075 : boolean_false_node,
13076 : build_int_cst (NULL, MEMMODEL_RELAXED),
13077 : build_int_cst (NULL, MEMMODEL_RELAXED));
13078 6 : gfc_add_expr_to_block (&block, tmp);
13079 :
13080 6 : if (stat != NULL_TREE)
13081 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
13082 6 : gfc_add_block_to_block (&block, &post_block);
13083 6 : return gfc_finish_block (&block);
13084 : }
13085 :
13086 : static tree
13087 105 : conv_intrinsic_event_query (gfc_code *code)
13088 : {
13089 105 : gfc_se se, argse;
13090 105 : tree stat = NULL_TREE, stat2 = NULL_TREE;
13091 105 : tree count = NULL_TREE, count2 = NULL_TREE;
13092 :
13093 105 : gfc_expr *event_expr = code->ext.actual->expr;
13094 :
13095 105 : if (code->ext.actual->next->next->expr)
13096 : {
13097 18 : gcc_assert (code->ext.actual->next->next->expr->expr_type
13098 : == EXPR_VARIABLE);
13099 18 : gfc_init_se (&argse, NULL);
13100 18 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
13101 18 : stat = argse.expr;
13102 : }
13103 87 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13104 58 : stat = null_pointer_node;
13105 :
13106 105 : if (code->ext.actual->next->expr)
13107 : {
13108 105 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
13109 105 : gfc_init_se (&argse, NULL);
13110 105 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
13111 105 : count = argse.expr;
13112 : }
13113 :
13114 105 : gfc_start_block (&se.pre);
13115 105 : if (flag_coarray == GFC_FCOARRAY_LIB)
13116 : {
13117 70 : tree tmp, token, image_index;
13118 70 : tree index = build_zero_cst (gfc_array_index_type);
13119 :
13120 70 : if (event_expr->expr_type == EXPR_FUNCTION
13121 0 : && event_expr->value.function.isym
13122 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
13123 0 : event_expr = event_expr->value.function.actual->expr;
13124 :
13125 70 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
13126 :
13127 70 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
13128 70 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
13129 : != INTMOD_ISO_FORTRAN_ENV
13130 70 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
13131 : != ISOFORTRAN_EVENT_TYPE)
13132 : {
13133 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
13134 : "yet supported", &event_expr->where);
13135 0 : return NULL_TREE;
13136 : }
13137 :
13138 70 : if (gfc_is_coindexed (event_expr))
13139 : {
13140 0 : gfc_error ("The event variable at %L shall not be coindexed",
13141 : &event_expr->where);
13142 0 : return NULL_TREE;
13143 : }
13144 :
13145 70 : image_index = integer_zero_node;
13146 :
13147 70 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
13148 : event_expr);
13149 :
13150 : /* For arrays, obtain the array index. */
13151 70 : if (gfc_expr_attr (event_expr).dimension)
13152 : {
13153 52 : tree desc, tmp, extent, lbound, ubound;
13154 52 : gfc_array_ref *ar, ar2;
13155 52 : int i;
13156 :
13157 : /* TODO: Extend this, once DT components are supported. */
13158 52 : ar = &event_expr->ref->u.ar;
13159 52 : ar2 = *ar;
13160 52 : memset (ar, '\0', sizeof (*ar));
13161 52 : ar->as = ar2.as;
13162 52 : ar->type = AR_FULL;
13163 :
13164 52 : gfc_init_se (&argse, NULL);
13165 52 : argse.descriptor_only = 1;
13166 52 : gfc_conv_expr_descriptor (&argse, event_expr);
13167 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
13168 52 : desc = argse.expr;
13169 52 : *ar = ar2;
13170 :
13171 52 : extent = build_one_cst (gfc_array_index_type);
13172 156 : for (i = 0; i < ar->dimen; i++)
13173 : {
13174 52 : gfc_init_se (&argse, NULL);
13175 52 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
13176 52 : gfc_add_block_to_block (&argse.pre, &argse.pre);
13177 52 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
13178 52 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
13179 52 : TREE_TYPE (lbound), argse.expr, lbound);
13180 52 : tmp = fold_build2_loc (input_location, MULT_EXPR,
13181 52 : TREE_TYPE (tmp), extent, tmp);
13182 52 : index = fold_build2_loc (input_location, PLUS_EXPR,
13183 52 : TREE_TYPE (tmp), index, tmp);
13184 52 : if (i < ar->dimen - 1)
13185 : {
13186 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13187 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13188 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13189 0 : TREE_TYPE (tmp), extent, tmp);
13190 : }
13191 : }
13192 : }
13193 :
13194 70 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13195 : {
13196 0 : count2 = count;
13197 0 : count = gfc_create_var (integer_type_node, "count");
13198 : }
13199 :
13200 70 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13201 : {
13202 0 : stat2 = stat;
13203 0 : stat = gfc_create_var (integer_type_node, "stat");
13204 : }
13205 :
13206 70 : index = fold_convert (size_type_node, index);
13207 140 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13208 : token, index, image_index, count
13209 70 : ? gfc_build_addr_expr (NULL, count) : count,
13210 70 : stat != null_pointer_node
13211 12 : ? gfc_build_addr_expr (NULL, stat) : stat);
13212 70 : gfc_add_expr_to_block (&se.pre, tmp);
13213 :
13214 70 : if (count2 != NULL_TREE)
13215 0 : gfc_add_modify (&se.pre, count2,
13216 0 : fold_convert (TREE_TYPE (count2), count));
13217 :
13218 70 : if (stat2 != NULL_TREE)
13219 0 : gfc_add_modify (&se.pre, stat2,
13220 0 : fold_convert (TREE_TYPE (stat2), stat));
13221 :
13222 70 : return gfc_finish_block (&se.pre);
13223 : }
13224 :
13225 35 : gfc_init_se (&argse, NULL);
13226 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13227 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13228 :
13229 35 : if (stat != NULL_TREE)
13230 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13231 :
13232 35 : return gfc_finish_block (&se.pre);
13233 : }
13234 :
13235 :
13236 : /* This is a peculiar case because of the need to do dependency checking.
13237 : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13238 : a special case and this function called instead of
13239 : gfc_conv_procedure_call. */
13240 : void
13241 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13242 : gfc_loopinfo *loop)
13243 : {
13244 197 : gfc_actual_arglist *actual;
13245 197 : gfc_se argse[5];
13246 197 : gfc_expr *arg[5];
13247 197 : gfc_ss *lss;
13248 197 : int n;
13249 :
13250 197 : tree from, frompos, len, to, topos;
13251 197 : tree lenmask, oldbits, newbits, bitsize;
13252 197 : tree type, utype, above, mask1, mask2;
13253 :
13254 197 : if (loop)
13255 67 : lss = loop->ss;
13256 : else
13257 130 : lss = gfc_ss_terminator;
13258 :
13259 : actual = actual_args;
13260 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13261 : {
13262 985 : arg[n] = actual->expr;
13263 985 : gfc_init_se (&argse[n], NULL);
13264 :
13265 985 : if (lss != gfc_ss_terminator)
13266 : {
13267 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13268 : /* Find the ss for the expression if it is there. */
13269 335 : argse[n].ss = lss;
13270 335 : gfc_mark_ss_chain_used (lss, 1);
13271 : }
13272 :
13273 985 : gfc_conv_expr (&argse[n], arg[n]);
13274 :
13275 985 : if (loop)
13276 335 : lss = argse[n].ss;
13277 : }
13278 :
13279 197 : from = argse[0].expr;
13280 197 : frompos = argse[1].expr;
13281 197 : len = argse[2].expr;
13282 197 : to = argse[3].expr;
13283 197 : topos = argse[4].expr;
13284 :
13285 : /* The type of the result (TO). */
13286 197 : type = TREE_TYPE (to);
13287 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13288 :
13289 : /* Optionally generate code for runtime argument check. */
13290 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13291 : {
13292 18 : tree nbits, below, ccond;
13293 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13294 18 : tree ln = fold_convert (long_integer_type_node, len);
13295 18 : tree tp = fold_convert (long_integer_type_node, topos);
13296 18 : below = fold_build2_loc (input_location, LT_EXPR,
13297 : logical_type_node, frompos,
13298 18 : build_int_cst (TREE_TYPE (frompos), 0));
13299 18 : above = fold_build2_loc (input_location, GT_EXPR,
13300 : logical_type_node, frompos,
13301 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13302 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13303 : logical_type_node, below, above);
13304 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13305 18 : &arg[1]->where,
13306 : "FROMPOS argument (%ld) out of range 0:%d "
13307 : "in intrinsic MVBITS", fp, bitsize);
13308 18 : below = fold_build2_loc (input_location, LT_EXPR,
13309 : logical_type_node, len,
13310 18 : build_int_cst (TREE_TYPE (len), 0));
13311 18 : above = fold_build2_loc (input_location, GT_EXPR,
13312 : logical_type_node, len,
13313 18 : fold_convert (TREE_TYPE (len), bitsize));
13314 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13315 : logical_type_node, below, above);
13316 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13317 18 : &arg[2]->where,
13318 : "LEN argument (%ld) out of range 0:%d "
13319 : "in intrinsic MVBITS", ln, bitsize);
13320 18 : below = fold_build2_loc (input_location, LT_EXPR,
13321 : logical_type_node, topos,
13322 18 : build_int_cst (TREE_TYPE (topos), 0));
13323 18 : above = fold_build2_loc (input_location, GT_EXPR,
13324 : logical_type_node, topos,
13325 18 : fold_convert (TREE_TYPE (topos), bitsize));
13326 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13327 : logical_type_node, below, above);
13328 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13329 18 : &arg[4]->where,
13330 : "TOPOS argument (%ld) out of range 0:%d "
13331 : "in intrinsic MVBITS", tp, bitsize);
13332 :
13333 : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13334 : integers. Additions below cannot overflow. */
13335 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13336 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13337 : long_integer_type_node, fp, ln);
13338 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13339 : logical_type_node, above, nbits);
13340 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13341 : &arg[1]->where,
13342 : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13343 : "in intrinsic MVBITS", fp, ln, bitsize);
13344 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13345 : long_integer_type_node, tp, ln);
13346 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13347 : logical_type_node, above, nbits);
13348 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13349 : &arg[4]->where,
13350 : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13351 : "in intrinsic MVBITS", tp, ln, bitsize);
13352 : }
13353 :
13354 1182 : for (n = 0; n < 5; n++)
13355 : {
13356 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13357 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13358 : }
13359 :
13360 : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13361 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13362 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13363 197 : mask1 = build_int_cst (type, -1);
13364 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13365 : build_int_cst (type, 1), len);
13366 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13367 : mask2, build_int_cst (type, 1));
13368 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13369 : above, mask1, mask2);
13370 :
13371 : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13372 : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13373 : * not strictly necessary; artificial bits from rshift will be masked. */
13374 197 : utype = unsigned_type_for (type);
13375 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13376 : fold_convert (utype, from), frompos);
13377 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13378 : fold_convert (type, newbits), lenmask);
13379 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13380 : newbits, topos);
13381 :
13382 : /* oldbits = TO & (~(lenmask << TOPOS)). */
13383 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13384 : lenmask, topos);
13385 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13386 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13387 :
13388 : /* TO = newbits | oldbits. */
13389 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13390 : oldbits, newbits);
13391 :
13392 : /* Return the assignment. */
13393 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13394 : void_type_node, to, se->expr);
13395 197 : }
13396 :
13397 : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13398 : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13399 : tree *stat, tree *errmsg, tree *errmsg_len);
13400 :
13401 : static tree
13402 263 : conv_intrinsic_move_alloc (gfc_code *code)
13403 : {
13404 263 : stmtblock_t block;
13405 263 : gfc_expr *from_expr, *to_expr;
13406 263 : gfc_se from_se, to_se;
13407 263 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13408 263 : bool coarray, from_is_class, from_is_scalar;
13409 263 : gfc_actual_arglist *arg = code->ext.actual;
13410 263 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13411 :
13412 263 : gfc_start_block (&block);
13413 :
13414 263 : from_expr = arg->expr;
13415 263 : arg = arg->next;
13416 263 : to_expr = arg->expr;
13417 263 : arg = arg->next;
13418 :
13419 789 : while (arg)
13420 : {
13421 526 : if (arg->expr)
13422 : {
13423 0 : if (!strcmp ("stat", arg->name))
13424 0 : tmp_sync_stat.stat = arg->expr;
13425 0 : else if (!strcmp ("errmsg", arg->name))
13426 0 : tmp_sync_stat.errmsg = arg->expr;
13427 : }
13428 526 : arg = arg->next;
13429 : }
13430 :
13431 263 : gfc_init_se (&from_se, NULL);
13432 263 : gfc_init_se (&to_se, NULL);
13433 :
13434 263 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13435 263 : if (stat != null_pointer_node)
13436 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13437 :
13438 263 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13439 263 : coarray = from_expr->corank != 0;
13440 :
13441 263 : from_is_class = from_expr->ts.type == BT_CLASS;
13442 263 : from_is_scalar = from_expr->rank == 0 && !coarray;
13443 263 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13444 : {
13445 163 : from_se.want_pointer = 1;
13446 163 : if (from_is_scalar)
13447 115 : gfc_conv_expr (&from_se, from_expr);
13448 : else
13449 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13450 163 : if (from_is_class)
13451 64 : from_tree = gfc_class_data_get (from_se.expr);
13452 : else
13453 : {
13454 99 : gfc_symbol *vtab;
13455 99 : from_tree = from_se.expr;
13456 :
13457 99 : if (to_expr->ts.type == BT_CLASS)
13458 : {
13459 36 : vtab = gfc_find_vtab (&from_expr->ts);
13460 36 : gcc_assert (vtab);
13461 36 : from_se.expr = gfc_get_symbol_decl (vtab);
13462 : }
13463 : }
13464 163 : gfc_add_block_to_block (&block, &from_se.pre);
13465 :
13466 163 : to_se.want_pointer = 1;
13467 163 : if (to_expr->rank == 0)
13468 115 : gfc_conv_expr (&to_se, to_expr);
13469 : else
13470 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13471 163 : if (to_expr->ts.type == BT_CLASS)
13472 100 : to_tree = gfc_class_data_get (to_se.expr);
13473 : else
13474 63 : to_tree = to_se.expr;
13475 163 : gfc_add_block_to_block (&block, &to_se.pre);
13476 :
13477 : /* Deallocate "to". */
13478 163 : if (to_expr->rank == 0)
13479 : {
13480 115 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13481 : true, to_expr, to_expr->ts,
13482 : NULL_TREE, false, true,
13483 : errmsg, errmsg_len);
13484 115 : gfc_add_expr_to_block (&block, tmp);
13485 : }
13486 :
13487 163 : if (from_is_scalar)
13488 : {
13489 : /* Assign (_data) pointers. */
13490 115 : gfc_add_modify_loc (input_location, &block, to_tree,
13491 115 : fold_convert (TREE_TYPE (to_tree), from_tree));
13492 :
13493 : /* Set "from" to NULL. */
13494 115 : gfc_add_modify_loc (input_location, &block, from_tree,
13495 115 : fold_convert (TREE_TYPE (from_tree),
13496 : null_pointer_node));
13497 :
13498 115 : gfc_add_block_to_block (&block, &from_se.post);
13499 : }
13500 163 : gfc_add_block_to_block (&block, &to_se.post);
13501 :
13502 : /* Set _vptr. */
13503 163 : if (to_expr->ts.type == BT_CLASS)
13504 : {
13505 100 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13506 100 : if (from_is_class)
13507 64 : gfc_reset_vptr (&block, from_expr);
13508 100 : if (UNLIMITED_POLY (to_expr))
13509 : {
13510 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13511 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13512 20 : ? from_se.string_length
13513 : : size_zero_node;
13514 20 : gfc_add_modify_loc (input_location, &block, to_len,
13515 20 : fold_convert (TREE_TYPE (to_len), tmp));
13516 : }
13517 : }
13518 :
13519 163 : if (from_is_scalar)
13520 : {
13521 115 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13522 : {
13523 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13524 6 : fold_convert (TREE_TYPE (to_se.string_length),
13525 : from_se.string_length));
13526 6 : if (from_expr->ts.deferred)
13527 6 : gfc_add_modify_loc (
13528 : input_location, &block, from_se.string_length,
13529 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13530 : }
13531 115 : if (UNLIMITED_POLY (from_expr))
13532 2 : gfc_reset_len (&block, from_expr);
13533 :
13534 115 : return gfc_finish_block (&block);
13535 : }
13536 :
13537 48 : gfc_init_se (&to_se, NULL);
13538 48 : gfc_init_se (&from_se, NULL);
13539 : }
13540 :
13541 : /* Deallocate "to". */
13542 148 : if (from_expr->rank == 0)
13543 : {
13544 4 : to_se.want_coarray = 1;
13545 4 : from_se.want_coarray = 1;
13546 : }
13547 148 : gfc_conv_expr_descriptor (&to_se, to_expr);
13548 148 : gfc_conv_expr_descriptor (&from_se, from_expr);
13549 148 : gfc_add_block_to_block (&block, &to_se.pre);
13550 148 : gfc_add_block_to_block (&block, &from_se.pre);
13551 :
13552 : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13553 : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13554 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13555 : {
13556 6 : tree cond;
13557 :
13558 6 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13559 : fin_label, true, to_expr,
13560 : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13561 : NULL_TREE, NULL_TREE,
13562 : gfc_conv_descriptor_token (to_se.expr),
13563 : true);
13564 6 : gfc_add_expr_to_block (&block, tmp);
13565 :
13566 6 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13567 6 : cond = fold_build2_loc (input_location, EQ_EXPR,
13568 : logical_type_node, tmp,
13569 6 : fold_convert (TREE_TYPE (tmp),
13570 : null_pointer_node));
13571 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13572 : 3, null_pointer_node, null_pointer_node,
13573 : integer_zero_node);
13574 :
13575 6 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13576 : tmp, build_empty_stmt (input_location));
13577 6 : gfc_add_expr_to_block (&block, tmp);
13578 6 : }
13579 : else
13580 : {
13581 142 : if (to_expr->ts.type == BT_DERIVED
13582 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13583 : {
13584 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13585 : to_se.expr, to_expr->rank);
13586 19 : gfc_add_expr_to_block (&block, tmp);
13587 : }
13588 :
13589 142 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13590 : fin_label, true, to_expr,
13591 : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13592 : NULL_TREE, NULL_TREE, true);
13593 142 : gfc_add_expr_to_block (&block, tmp);
13594 : }
13595 :
13596 : /* Copy the array descriptor data. */
13597 148 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13598 :
13599 : /* Set "from" to NULL. */
13600 148 : tmp = gfc_conv_descriptor_data_get (from_se.expr);
13601 148 : gfc_add_modify_loc (input_location, &block, tmp,
13602 148 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
13603 :
13604 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13605 : {
13606 : /* Copy the array descriptor data has overwritten the to-token and cleared
13607 : from.data. Now also clear the from.token. */
13608 6 : gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
13609 : null_pointer_node);
13610 : }
13611 :
13612 148 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13613 : {
13614 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13615 7 : fold_convert (TREE_TYPE (to_se.string_length),
13616 : from_se.string_length));
13617 7 : if (from_expr->ts.deferred)
13618 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13619 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13620 : }
13621 148 : if (fin_label)
13622 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13623 :
13624 148 : gfc_add_block_to_block (&block, &to_se.post);
13625 148 : gfc_add_block_to_block (&block, &from_se.post);
13626 :
13627 148 : return gfc_finish_block (&block);
13628 : }
13629 :
13630 :
13631 : tree
13632 6831 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13633 : {
13634 6831 : tree res;
13635 :
13636 6831 : gcc_assert (code->resolved_isym);
13637 :
13638 6831 : switch (code->resolved_isym->id)
13639 : {
13640 263 : case GFC_ISYM_MOVE_ALLOC:
13641 263 : res = conv_intrinsic_move_alloc (code);
13642 263 : break;
13643 :
13644 14 : case GFC_ISYM_ATOMIC_CAS:
13645 14 : res = conv_intrinsic_atomic_cas (code);
13646 14 : break;
13647 :
13648 95 : case GFC_ISYM_ATOMIC_ADD:
13649 95 : case GFC_ISYM_ATOMIC_AND:
13650 95 : case GFC_ISYM_ATOMIC_DEF:
13651 95 : case GFC_ISYM_ATOMIC_OR:
13652 95 : case GFC_ISYM_ATOMIC_XOR:
13653 95 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13654 95 : case GFC_ISYM_ATOMIC_FETCH_AND:
13655 95 : case GFC_ISYM_ATOMIC_FETCH_OR:
13656 95 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13657 95 : res = conv_intrinsic_atomic_op (code);
13658 95 : break;
13659 :
13660 176 : case GFC_ISYM_ATOMIC_REF:
13661 176 : res = conv_intrinsic_atomic_ref (code);
13662 176 : break;
13663 :
13664 105 : case GFC_ISYM_EVENT_QUERY:
13665 105 : res = conv_intrinsic_event_query (code);
13666 105 : break;
13667 :
13668 3218 : case GFC_ISYM_C_F_POINTER:
13669 3218 : case GFC_ISYM_C_F_PROCPOINTER:
13670 3218 : res = conv_isocbinding_subroutine (code);
13671 3218 : break;
13672 :
13673 60 : case GFC_ISYM_C_F_STRPOINTER:
13674 60 : res = conv_isocbinding_subroutine_strpointer (code);
13675 60 : break;
13676 :
13677 360 : case GFC_ISYM_CAF_SEND:
13678 360 : res = conv_caf_send_to_remote (code);
13679 360 : break;
13680 :
13681 140 : case GFC_ISYM_CAF_SENDGET:
13682 140 : res = conv_caf_sendget (code);
13683 140 : break;
13684 :
13685 88 : case GFC_ISYM_CO_BROADCAST:
13686 88 : case GFC_ISYM_CO_MIN:
13687 88 : case GFC_ISYM_CO_MAX:
13688 88 : case GFC_ISYM_CO_REDUCE:
13689 88 : case GFC_ISYM_CO_SUM:
13690 88 : res = conv_co_collective (code);
13691 88 : break;
13692 :
13693 10 : case GFC_ISYM_FREE:
13694 10 : res = conv_intrinsic_free (code);
13695 10 : break;
13696 :
13697 55 : case GFC_ISYM_FSTAT:
13698 55 : case GFC_ISYM_LSTAT:
13699 55 : case GFC_ISYM_STAT:
13700 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13701 55 : break;
13702 :
13703 90 : case GFC_ISYM_RANDOM_INIT:
13704 90 : res = conv_intrinsic_random_init (code);
13705 90 : break;
13706 :
13707 15 : case GFC_ISYM_KILL:
13708 15 : res = conv_intrinsic_kill_sub (code);
13709 15 : break;
13710 :
13711 : case GFC_ISYM_MVBITS:
13712 : res = NULL_TREE;
13713 : break;
13714 :
13715 194 : case GFC_ISYM_SYSTEM_CLOCK:
13716 194 : res = conv_intrinsic_system_clock (code);
13717 194 : break;
13718 :
13719 102 : case GFC_ISYM_SPLIT:
13720 102 : res = conv_intrinsic_split (code);
13721 102 : break;
13722 :
13723 : default:
13724 : res = NULL_TREE;
13725 : break;
13726 : }
13727 :
13728 6831 : return res;
13729 : }
13730 :
13731 : #include "gt-fortran-trans-intrinsic.h"
|
